perm filename BOOTST.PAS[PAS,SYS] blob
sn#474570 filedate 1979-09-07 generic text, type T, neo UTF8
(* pascal compiler. *) (* docUMENTATION. *)
(*$T-,S1500,R120*)
(********************************************************************************
*
* (C) COPYRIGHT ARMANDO R. RODRIGUEZ.
* STANFORD UNIVERSITY
* COMPUTER SCIENCE DEPARTMENT
* STANFORD, CA. 94305
* U. S. A.
* 1978
*
* P A S C A L
* -----------
*
* COMPILER FOR PASCAL, PRODUCED AT STANFORD
* UNIVERSITY FROM THE DECSYSTEM-10 PASCAL COMPILER WRITTEN BY
* H. H. NAGEL, UNIVERSITY OF HAMBURG. AUG-1978.
*
* general permission to make fair use in teaching or research of all or part
* of this material is granted to individuals and nonprofit institutions for
* nonprofit purposes provided that the above copyright notice is given.
*
********************************************************************************)
(********************************************************************************
*
* HISTORY OF PREVIOUS VERSIONS
* ****************************
*
*
* MAR-73 SYNTAX ANALYSIS INCLUDING ERROR HANDLING,
* CHECKS BASED ON DECLARATIONS AND ADDRESS-
* AND CODE-GENERATION FOR A HYPOTHETICAL
* STACK COMPUTER BY URS AMMAN
*
* FACHGRUPPE COMPUTER-WISSENSCHAFTEN
* EIDG. TECHNISCHE HOCHSCHULE
* CH-8006 ZUERICH
*
* DEC-73 CODE-GENERATION FOR DECSYSTEM-10
* BY C.O. GROSSE-LINDEMANN, F.W. LORENZ,
* H.H. NAGEL AND P.J. STIRL /1/
*
* JUL-74 IMPLEMENTATION OF NEW FEATURES BY STUDENTS
* DURING A PRACTICAL PROGRAMMING COURSE /2/
*
* DEC-74 MODIFICATIONS TO GENERATE RELOCATABLE
* LINK-10 OBJECT-CODE BY E. KISICKI
*
* DEC-74 DEBUG SYSTEM /5/
* BY P. PUTFARKEN
*
* APR-76 POST-MORTEM DUMP FACILITY /6/
* BY B. NEBEL AND B. PRETSCHNER
*
* AUG-76 IMPROVEMENTS AND ADAPTATION TO STANDARD-PASCAL
* AND CDC 6000-3.4. PASCAL AS PRESENTED IN
* "PASCAL - USER MANUAL AND REPORT" /3,4,7/
* BY E.KISICKI
*
* NOV-76 FORMAL PROCEDURE/FUNCTION PARAMETERS
* AND CORRECTION OF ERRORS
* BY H. LINDE
*
* INSTITUT FUER INFORMATIK
* SCHLUETERSTRASSE 70
* D-2000 HAMBURG 13
*
* /1/ F.W. LORENZ, P.J. STIRL
* UEBERTRAGUNG EINES PASCAL-COMPILERS AUF DAS DECSYSTEM-10
* DIPLOMARBEIT, IFI, HH, 74
*
* C.O. GROSSE-LINDEMANN, H.H. NAGEL
* POSTLUDE TO A PASCAL-COMPILER BOOTSTRAP
* BERICHT NR. 11, IFI, HH, 74
*
* C.O. GROSSE-LINDEMANN
* WEITERFUEHRENDE ARBEITEN AM PASCAL-COMPILER ZUR
* STEIGERUNG DER BENUTZERFREUNDLICHKEIT
* DIPLOMARBEIT, IFI, HH, 75
*
* /2/ ERWEITERUNG VON SPRACHDEFINITION, COMPILER UND LAUFZEIT-
* UNTERSTUETZUNG BEI PASCAL/ ERGEBNISSE EINES PRAKTIKUMS
* IM INFORMATIK GRUNDSTUDIUM
* STUD. BEITRAEGE BEARBEITET VON H.H. NAGEL
* MITTEILUNGEN NR. 16, IFI, HH, 75
*
* /3/ H.H. NAGEL
* PASCAL FOR DECSYSTEM-10/ EXPERIENCES AND FURTHER PLANS
* MITTEILUNGEN NR. 21, IFI, HH, NOV-75
*
* /4/ KATHLEEN JENSEN, NIKLAUS WIRTH
* PASCAL USER MANUAL AND REPORT
* LECTURE NOTES IN COMPUTER SCIENCE VOL 18
* SPRINGER-VERLAG BERLIN-HEIDELBERG-NEW YORK
*
* /5/ P. PUTFARKEN
* TESTHILFEN FUER PASCAL PROGRAMME
* DIPLOMARBEIT, IFI, HH, 76
*
* /6/ B. NEBEL, B. PRETSCHNER
* ERWEITERUNG DES DECSYSTEM-10 PASCAL COMPILERS UM
* EINE MOEGLICHKEIT ZUR ERZEUGUNG EINES POST-MORTEM DUMP
* MITTEILUNGEN NR. 34 , IFI, HH, JUN-76
*
* /7/ E. KISICKI, H.H. NAGEL
* PASCAL FOR THE DECSYSTEM-10
* MITTEILUNGEN NR. , IFI, HH, NOV-76
*
********************************************************************************)
(********************************************************************************
*
* CHANGES MADE AT LOTS, STANFORD UNIVERSITY:
*
*
* JAN-78 JOHN HENNESSY.
* (0) CHANGES NEEDED TO IMPLEMENT AT LOTS.
*
* JUN-78 MAN CHOR KO.
* (1) MODIFY THE CCL SCANNER (GETFILENAME) TO
* TAKE THE LOCAL STANDARD: SWITCHES IN THE FIRST LINE,
* SECOND LINE FOR A FILE NAME TO BE CALLED AFTER THE COMPILER.
*
* JUL-78 ARMANDO R. RODRIGUEZ. SMALL FIXINGS:
* (2) AVOID RECURSION ON SCANNING COMMENTS.
* (3) DON'T TAKE backarrow AS A COMMENT END UNLESS STARTED BY '%'.
* (4) CALL PCROSS AND PASS IT ITS PARAMETERS PROPERLY.
* (5) USE A BIG VALUE FOR RUNCORE.
* (6) GIVE PAGE NUMBERS ON TTY.
* (7) KNOW ABOUT SEVERAL NEW RUNTIMES FROM THE CCL SCANNER.
* (8) IMPLEMENT THE SWITCH /VERSION:<GOODVERSION>, OPTION
* V<GOODVERSION>, TO ALLOW FOR CONDITIONAL COMPILATION: IF
* A COMMENT IS OPEN WITH %<N> WHERE <N> IS THE SAME DIGIT AS
* <GOODVERSION>, INCLUDE IT.
* (9) CCL SCANNER: IF A DEVICE NAME IS GIVEN, DON'T
* ASUME THE FILE NAME WAS DEFAULTED.
* (10) WORK PROPERLY WITH ALL COMPILE-CLASS COMMANDS, INCLUDING DEBUG.
* (11) WHEN GETTING PARAMETER FILE NAMES FROM TTY, ALLOW
* FOR DEFAULT OF OBJECT AND LIST FILES: DEFAULT TO <SOURCE>.REL AND .LST.
* (12) RUNTIME CHECK FOR NIL OR ZERO POINTERS.
* (13) OTHER SMALL FIXINGS: REORDER BODY OF INITPROCEDURES;
* APPROPRIATE MESSAGE ON SEGMENTED FILES; TAKE LOADER TMPCORE
* FILE FROM DEBUG COMMAND PROPERLY; TAKE U- SWITCH PROPERLY;
* CANCEL LOAD IF E+ SWITCH PRESENT; ACCEPT EXTRA SEMICOLONS
* IN CASE, BOTH RECORD AND STATEMENT; ACCEPT NULL VARIANT
* PARTS OF RECORDS; PROMPT TTY INPUT FILES PROPERLY; SEND
* BEL ONLY IF NOT CALLING LOADER; COUNT ERRORS OF THE WHOLE
* FILE IN MULTIPLE-PROGRAM FILES; REWRITE OUTPUT ONLY IF NEEDED.
*
* AUG-78 ARMANDO R. RODRIGUEZ:
* (16) (THANKS TO KO) FIX A BUG BY WHICH, WHEN YOU READ OR
* WRITE AN ARRAY ELEMENT SUBSCRIPTED BY A MOD EXPRESSION, THE
* GENERATED CODE WOULD READ/WRITE THE CORRESPONDING DIV EXPRESSION,
* INSTEAD OF THE ARRAY ELEMENT. (SUPPRESSED 9-AUG-78. IT INDUCED ANOTHER BUG.)
* (22) AVOID GENERATION OF CODE IN THE CASE THAT ANY ERROR
* HAS BEEN DETECTED. (SPEED-UP).
* (23) TO SIMPLIFY CONSISTENCY, USE THE LIBRARY ROUTINES
* TO REPORT RUNTIME AND FOR GET←DIRECTIVES.
*
* SEP-78 ARMANDO R. RODRIGUEZ.
* (25) IMPLEMENT A NON-STANDARD STRING PACKAGE. TO
* DISABLE IT, CHANGE THE CONSTANT STRINGPACK TO FALSE.
*
********************************************************************************)
(********************************************************************************
*
* HINTS TO INTERPRET ABBREVIATIONS
*
* BRACK : BRACKET "[ ]" IX : INDEX
* C : CURRENT L : LOCAL
* C : COUNTER L : LEFT
* CST : CONSTANT PARENT : "( )"
* CTP : IDENTIFIER POINTER P/PTR : POINTER
* EL : ELEMENT P/PROC : PROCEDURE
* F : FORMAL R : RIGHT
* F : FIRST S : STRING
* F : FILE SY : SYMBOL
* F/FUNC : FUNCTION V : VARIABLE
* G : GLOBAL V : VALUE
* ID : IDENTIFIER BP : BYTEPOINTER
* REL : RELATIVE REL : RELOCATION
*
********************************************************************************)
(********************************************************************************
*
* FILES NECESSARY TO IMPLEMENT THE PASCAL COMPILER
* NOTE: THIS LIST HAS BEEN MODIFIED TO FIT LOTS COMPUTER FACILITY
*
* SOURCE-CODE
*
* PASCAL.PAS : PASCAL COMPILER
*
* LIBPAS.PAS : CCL (OPTION, GETOPTION, GETFILENAME, GETPARAMETER,
* ASKFILENAME, STARTFILE, GETNEXTCALL, REENTER)
* DDT (DEBUG)
* STATUS (GETSTATUS)
* READ (READIRANGE, READCRANGE, READRRANGE, READSCALAR,
* READISET, READCSET, READDSET)
* WRITE (WRTSCALAR, WRTISET, WRTDSET,WRTCSET)
* TIMING (SETRUNTIME, SETELAPSEDTIME, SETTIME,
* RUNTIME, ELAPSEDTIME, TIMEREPORT)
* STRLIB (CREATE, LENGTH, INDEX, SUBSTR, GETCHAR,
* PUTCHAR, COMPSTR, READSTR)
*
* LIBMAC.MAC : MACRO RUNTIME SUPPORT
*
* PCROSS.PAS : CROSS REFERENCE WITHOUT CODE-GENERATION
*
*
* OBJECT-CODE
*
* PASLIB.REL : SEARCH LIBRARY CONTAINING LIBPAS.REL
* AND LIBMAC.REL
*
*
* EXECUTABLE-CODE
*
* PASCAL.EXE : PASCAL EXECUTABLE MODULE
* PCROSS.EXE : PCROSS EXECUTABLE MODULE
*
*
* INFORMATION AND MAINTENANCE
*
* PASCAL.MAN : A GUIDE FOR THE LOTS PASCAL/PASSGO DIALECT
*
*******************************************************************************)
(*******************************************************************************
*
* HOW TO GENERATE A NEW PASCAL COMPILER
* NOTE: THIS INFORMATION HAS BEEN UPDATED TO REFLECT THE
* SITUATION AT LOTS.
*
* 1) CHANGES TO THE RUNTIME-SUPPORT
*
* LET LIBPAS.PAS AND LIBMAC.MAC BE YOUR MODIFIED RUNTIME SUPPORT
*
* @COMPILE LIBMAC.MAC/LIST
* ...
* @COMPILE LIBPAS.PAS/LIST
* PASCAL: LIBPAS [CCL: OPTION, ... ] 1.. 2..
* ...
* PASCAL: LIBPAS [DEBUG: DEBUG] 2.. 3..
* ...
* EXIT
* @RENAME PASLIB.REL PASLIB.OLD
* @MAKLIB
* *PASLIB=LIBPAS,LIBMAC/APPEND
* *PASLIB=PASLIB/POINTS
* *↑C
* @PRINT PASLIB.LST
*
*
* 2) CHANGES TO THE COMPILER
*
* LET PASCAL.PAS BE YOUR NEW COMPILER SOURCE
* (DO NOT FORGET TO CHANGE THE "HEADER" AND CHECK FOR THE CORRECT
* FILE DESCRIPTIONS FOR PASLIB AND PCROSS IN INITPROCEDURE
* "SEARCH LIBRARIES")
*
* @PASCAL
* OBJECT = P1/EXECUTE
* LIST = <CR>
* SOURCE = PASCAL/VERSION:1
* PASCAL: P1 [PASCAL] 1..
* 0 ERROR(S) DETECTED
* ...
* LINK: LOADING
* [...P1 EXECUTION]
* OBJECT= P2/EXECUTE
* LIST= <CR>
* SOURCE= PASCAL/VERSION:1
* PASCAL: P2 [PASCAL] 1..
* 0 ERROR(S) DETECTED
* ...
* LINK: LOADING
* [...P2 EXECUTION]
* OBJECT= P3
* LIST= <CR>
* SOURCE= PASCAL/VERSION:1
* PASCAL: P3 [PASCAL] 1..
* 0 ERROR(S) DETECTED
* ...
* EXIT
* @ FILCOM
* *TTY:=P2.REL,P3.REL
* NO DIFFERENCES ENCOUNTERED
* *↑C
* @DELETE P1.*,P3.*
* @RENAME P2.* PASCAL
* @RENAME PASCAL.PAS PASCAL.OLD
* @RENAME PASCAL.NEW PASCAL.PAS
* @LOAD PASCAL/MAP
* @SAVE PASCAL
* @PCROSS
* OLDSOURCE = PASCAL.PAS
* NEWSOURCE = PASCAL.PAS/COMM:U
* CROSSLIST = PASCAL.CRL
* PCROSS: PASCAL [PASCAL] 1..
* 0 ERROR(S) DETECTED
* EXIT
*
*
* 3) CHANGES TO PCROSS
*
* @LOAD PCROSS/LIST/COMPILE
* ...
* EXIT
* @SAVE PCROSS
*
********************************************************************************)
(*******************************************************************************
*
* KNOWN BUGS AND RESTRICTIONS
*
* 1) IF THE DEVICE-PARAMETER FOR RESET/REWRITE IS NOT
* DEFAULTED, NEW BUFFERS ARE ALLOCATED WITHOUT REGARD
* TO THE FACT THAT THE NEW DEVICE COULD BE THE SAME AS THE
* THE OLD DEVICE.
*
* 2) COMPARISON OF VARIABLES OF TYPE PACKED RECORD OR
* PACKED ARRAY MAY CAUSE TROUBLE IF THESE VARIABLES APPEAR
* IN A VARIANT PART OR WERE ASSIGNED FROM A VARIANT PART
*
* 3) TOO LARGE ARRAY DIMENSIONS (F.E. MININT..MAXINT) CAUSE
* ARITHMETIC OVERFLOW INSTEAD OF AN APPROPRIATE ERROR
* MESSAGE
*
* 4) ARRAYS OF FILE AND RECORDS WITH FILES AS COMPONENTS
* ARE NOT IMPLEMENTED
*
* 5) SEGMENTED FILES ARE NOT IMPLEMENTED
*
* 6) CALL OF EXTERNAL COBOL OR ALGOL PROCEDURES IS
* NOT IMPLEMENTED
*
*
********************************************************************************)
(********************************************************************************
*
* WHAT TO DO TO ADD PROCEDURES TO THE LIBRARY
* WHEN YOU ADD ANY PROCEDURE OR FUNCTION TO THE LIBRARY, YOU
* NEED TO DO THE FOLLOWING, FOR THE COMPILER TO KNOW ABOUT IT:
*
* 1. A) IF IT IS A PREDECLARED PROCEDURE OR FUNCTION:
* A1. IN INITPROCEDURE (*STANDARD NAMES :
* ADD ITS NAME TO NA[DECLPROC] OR NA[DECLFUNC]
* INCREMENT THE VALUE OF NAMAX[DECLPROC] OR NAMAX[DECLFUNC]
* A2. IN INITPROCEDURE (*PROCEDURE/FUNCTION NAMES :
* ADD THE ENTRYPOINT NAME (THE FIRST SIX CHARACTERS
* OF THE NAME OF THE PROCEDURE OR FUNCTION) TO
* EXTNA[DECLPROC] OR EXTNA[DECLFUNC]. DEFINE THE
* CORRESPONDING ELEMENT OF EXTLANGUAGE ACCORDINGLY.
*
* B) IF IT IS A RUNTIME SUPPORT PROCEDURE:
* B1. ADD A NEW MEMBER TO THE TYPE SUPPORTS, AT THE END
* B2. IN INITPROCEDURE (*RUNTIME-, DEBUG-SUPPORT NAMES :
* AD THE ENTRYPOINT NAME TO RUNTIME←SUPPORT.NAME
* (IF IT IS PART OF THE SUPPORTS FOR READ/WRITE, YOU
* NEED TO ADD AN ELEMENT TO TYPE SCALARFORM, OR CHANGE
* THE BOUNDS OF SUBSCRIPTS OF WRITE←SUPPORT, READ←SUPPORT,
* AND ADD THE CORRESPONDING VALUE FROM SUPPORTS TO
* THE CORRESPONDING ARRAY, IN THIS INITPROCEDURE)
*
* 3. FOR PREDECLARED PROCEDURES/FUNCTIONS, YOU NEED TO ENTER THEN
* IN THE SYMBOL TABLE. ADD CODE AT THE END OF PROCEDURE
* ENTERSTDNAMES. FOLLOW THE MODEL GIVEN BY THE OTHER PROCEDURES:
* A) CALL ENTERSTDPARAMETER ONCE FOR EACH PARAMETER, STARTING
* WITH THE LAST. THE PARAETERS ARE: TYPE POINTER, FORMAL/ACTUAL
* (I.E., DECLARED AS VAR, YES/NO),A POINTER, EXPECTED
* POSITION. YHE POINTER SHOULD BE NIL IN THE FIRST CALL,
* CP IN ALL THE OTHERS. THE POSITION HAS TO BE FIGURED:
* THE FIRST PARAMETER (THE LAST CALL) GETS 1; FROM THEN ON,
* YOU INCREMENT IT BY THE NUMBER OF WORDS OCCUPIED BY
* EACH PARAMETER: ONE FOR SIMPLE TYPES AND FORMAL PARAMETERS
* AND POINTERS, TWO FOR PACKED ARRAYS OF CHAR OF LENGHT
* 6 TO 10, WHICH ARE ACTUAL PARAMETERS, ETC.
* B) CALL ENTERSTDPROCFUNC. PARAMETERS ARE: THE VALUE OF THE
* SECOND SUBSCRIPT OF ITS NAME IN ARRAY NA, PROC OR FUNC
* ACCORDING TO WHETHER THE FIRST SUBSCRIPT IS DECLPROC OR
* DECLFUNC, TYPE POINTER FOR WHAT IT RETURNS (NIL FOR
* PROCEDURES), AND CP.
*
* 4. IF THEY NEED SPECIAL TREATMENT FOR THE PARAMETER CHECKING,
* THAT IS, IF THEY TAKE DEFAULTS, ACCEPT SEVERAL TYPES FOR
* A GIVEN PARAMETER, OR HAVE OPTIONAL PARAMETERS (LIKE READ
* OR WRITE), YOU HAVE TO MAKE A PROCEDURE TO PARSE THEIR
* PARAMETERS WHEN CALLED. THAT IS DONE BY PROCEDURE CALL,
* INSIDE STATEMENT, AND THE PROCEDURES THAT ARE ALREADY THERE
* SHOULD SERVE YOU WELL AS EXAMPLES OF HOW TO DO IT.
*
********************************************************************************)
(* GLOBAL DECLARATIONS. *)
PROGRAM pascal (object);
LABEL
0;
CONST
(* NIL = 377777B; *)
(* ALFALENGTH = 10; *)
(* MININT = 400000000000B; *)
(* MAXINT = 377777777777B; *)
(* MAXREAL = 1.7014118432E+38; *)
(* SMALLREAL= 1.4693680107E-39; *)
(* INF = 0; UNLESS STRINGPACK IS FALSE - 25.*)
header = 'PASCAL AT LOTS FROM 1-NOV-78';
(*COMPILER PARAMETERS:*)
(**********************)
displimit = 20; (* MAXIMUM DECLARATION-SCOPE NESTING *)
max←file = 12; (* MAXIMUM NUMBER OF USER-DECLARED FILES *)
max←channel = 15; (* HIGHEST DATA-CHANNEL ASSIGNED TO A FILE *)
maxlevel = 10; (* MAXIMUM PROC/FUNC LEVEL *)
strglgth = 135; (* MAXIMUM LENGTH FOR STRING-CONSTANT *) (* 25. INCREASED FROM 120.*)
xtrastrglgth = 136; (* 25. FOR PARAMETERS TO STRING PROCEDURE CALLS.*)
sizeoffileblock = 21; (* SIZE OF FILE CONTROL-BLOCK *)
cixmax = 1000; (* STANDARD SIZE OF CODE-ARRAY *)
maxerr = 4; (* MAXIMUM OF ERRORS IN 1 SOURCE-LINE *)
labmax = 9999; (* MAXIMUM VALUE OF A PROGRAM LABEL *)
bitmax = 36; (* NR. OF BITS OF 1 DECSYSTEM-10 MACHINE-WORD *)
hwcstmax = 377777B; (* MAXIMUM POS. INTEGER IN HALFWORD *)
entrymax = 20; (* MAXIMUM ENTRIES INTO EXTERN PROGRAM *)
extpfmax = 29; (* MAXIMUM OF EXTERN STANDARD PROC/FUNC *) (* 25. *)
stdmax = 36; (* NR. OF STANDARD NAMES *)
rswmax = 42; (* NR. OF RESERVED WORDS *)
rswmaxp1 = 43; (* RESERVED WORDS PLUS 1 *)
stdchcntmax = 132; (* MAXIMUM OF CHARS IN SOURCE-LINE *)
basemax = 71; (* MAXIMUM VALUE OF A SET ELEMENT *)
offset = 40B; (* USED FOR SETS OF CHARACTERS *)
buffer←size = 200B; (* DECSYSTEM-10 DISK-BUFFER SIZE *)
tagfmax = 5; (* MAX. NR. OF VARIANTS ALLOWED IN CALL OF "NEW" *)
jump←max = 50; (* MAX. NR. OF LABEL DECLARATIONS *)
maxpcrossoption = 19; (* 4. NR. OF OPTION SWITCHES OF PCROSS *)
reg0 = 0; (* WORKREGISTER *)
reg1 = 1; (* WORKREGISTER (USED FOR ARRAY-BYTEPOINTERS) *)
regin = 1; (* TO INITIALIZE REGC *)
stdparregcmax = 6; (* HIGHEST REGISTER USED FOR PARAMETERS *)
within = 12; (* FIRST REGISTER FOR WITH-STACK *)
newreg = 13; (* LAST PLACE OF NEW-STACK *)
basis = 14; (* ADDR OF CURRENT ACTIVATION-REC, STATIC AND DYNAMIC LINK *)
topp = 15; (* FIRST FREE WORD IN DATA-STACK *)
jbrel = 44B; (* LOCATION OF (0,HIGHEST LEGAL LOW-SEG ADDRESS) *)
jbsa = 120B; (* LOCATION OF (1ST UNUSED LOW-SEG ADDRESS,START-ADDRESS OF PROGRAM) *)
(* JBFF = 121B; (* LOCATION OF (0,POINTER BEHIND LAST FILE-BUFFER) *) (* NOT USED.*)
jbapr = 125B; (* LOCATION OF (0,PC AFTER PROGRAM ERROR) *)
jbddt = 74B; (* LOCATION OF (LAST PASDDT-ADDR, PASDDT-ADDR + 2) *)
tty←sixbit = 646471B; (* SIXBIT REPR. FOR 'TTY ' *)
dsk←sixbit = 446353B; (* SIXBIT REPR. FOR 'DSK ' *)
ascii←mode = 0; (* (SYSTEM-) FLAGS FOR ASCII-MODE *)
binary←mode = 14B; (* (SYSTEM-) FLAGS FOR BINARY-MODE *)
text←file = 0; (* (PASCAL-) FLAGS FOR "PACKED FILE OF (SUBRANGE OF) CHAR" = "TEXT" *)
data←file = 1; (* (PASCAL-) FLAGS FOR OTHER FILES *)
debug←save = 0B; (* ADDR OF DEBUG-SYSTEM STACK *)
debug←stop = 1B; (* PUSHJ INTO DEBUG ON "STOP" *)
(* DEBUG←PAGEHEAD = 2B; (* START OF "STOP"-CHAIN *) (* NOT USED.*)
debug←stackbottom = 3B; (* 1ST WORD OF PROGRAM-STACK *)
debug←initialization = 6B; (* PUSHJ INTO DEBUG-INITIALIZATION *)
debug←programname = 7B; (* ADDR OF ADDR OF PROGRAMNAME *)
system←low←start = 140B; (* LOC 0B..137B CONTAIN SYSTEM-INFO. *)
(* SYSTEM←HIGH←START = 400010B; (* LOC 400000B..400007B CONTAIN SYSTEM-INFO. *) (* NOT USED.*)
low←start = 10B; (* LOC 0B..7B RESERVED FOR DEBUG-PROGR. *)
high←start = 400000B; (* START OF EXECUTABLE CODE *)
maxaddr = 777777B; (* HIGHEST LEGAL ADDRESS *)
item←1 = 1; (* LINK ITEM 1: CODE *)
item←2 = 2; (* LINK ITEM 2: SYMBOLS *)
item←3 = 3; (* LINK ITEM 3: HIGHSEG *)
item←4 = 4; (* LINK ITEM 4: ENTRIES *)
item←5 = 5; (* LINK ITEM 5: LOW-/ HIGHSEGMENT BREAK *)
item←6 = 6; (* LINK ITEM 6: PROGRAM NAME *)
item←7 = 7; (* LINK ITEM 7: START ADDRESS *)
item←10 = 10B; (* LINK ITEM 10: INTERNAL REQUESTS *)
item←17 = 17B; (* LINK ITEM 17: LINK LIBRARIES *)
entry←symbol = 0; (* ENTRY SYMBOL FLAG *)
global←symbol = 1; (* GLOBAL SYMBOL FLAG *)
local←symbol = 2; (* LOCAL SYMBOL FLAG *)
sixbit←symbol = 6; (* SIXBIT SYMBOL FLAG *)
extern←symbol = 14B; (* EXTERN SYMBOL FLAG *)
stringpack = true; (* 25. IF FALSE, NON-STANDARD STRING PACKAGE IS DEACTIVATED.*)
TYPE
(* INTEGER = MININT..MAXINT *)
(* REAL = -MAXREAL..MAXREAL *)
(* CHAR = ' '..'←' *)
(* ASCII = NUL..DEL *)
(* BOOLEAN = (FALSE,TRUE) *)
(* TEXT = PACKED FILE OF CHAR *)
(* ALFA = PACKED ARRAY[1..ALFALENGTH] OF CHAR *)
(*DESCRIBING:*)
(*************)
(*BASIC SYMBOLS*)
(***************)
symbol = (ident,intconst,realconst,stringconst,notsy,mulop,addop,relop,
lparent,rparent,lbrack,rbrack,comma,semicolon,period,arrow,
colon,becomes,labelsy,constsy,typesy,varsy,functionsy,
proceduresy,packedsy,setsy,arraysy,recordsy,filesy,forwardsy,
beginsy,ifsy,casesy,repeatsy,whilesy,forsy,withsy,loopsy,
gotosy,exitsy,endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy,
externsy,pascalsy,fortransy,programsy, thensy,othersy,initprocsy,segmentsy,otherssy);
operator = (noop,mul,rdiv,andop,idiv,imod,plus,minus,orop,
ltop,leop,geop,gtop,neop,eqop,inop);
setofsys = SET OF symbol;
(*BASIC RANGE DEFINITIONS*)
(*************************)
levrange = 0..maxlevel;
keyrange = 0..77B;
fileformrange = 0..77B;
filemoderange = 0..77B;
addrrange = 0..maxaddr;
instrange = 0..677B;
radixrange = 0..37777777777B;
flagrange = 0..17B;
bitrange = 0..bitmax;
acrange = 0..15;
ibrange = 0..1;
coderange = 0..hwcstmax;
bits5 = 0..37B;
bits6 = 0..77B;
bits7 = 0..177B;
bits12 = 0..7777B;
bits18 = 0..777777B;
setrange = 0..basemax;
jump←range = 1..jump←max;
(*CONSTANTS*)
(***********)
bpointer = PACKED RECORD
sbits,pbits: bitrange;
ibit,dummybit: ibrange;
ireg: acrange;
reladdr: addrrange
END;
cstclass = (int,reel,pset,strd,strg,bptr);
csp = ↑ constnt;
constnt = RECORD
selfcsp: csp; nocode: boolean;
CASE cclass: cstclass OF
int : (intval: integer;
intval1:integer (*TO ACCESS SECOND WORD OF PVAL*) );
reel: (rval: real);
pset: (pval: SET OF setrange);
strd,
strg: (slgth: 0..strglgth;
sval: PACKED ARRAY [1..strglgth] OF char);
bptr: (byte: bpointer)
END;
valu = RECORD
CASE integer OF
1: (ival: integer);
2: (valp: csp);
3: (byte: bpointer)
END;
(*DATA STRUCTURES*)
(*****************)
structform = (scalar,subrange,pointer,power,arrays,records,files,tagfwithid,tagfwithoutid,variant);
declkind = (standard,declared);
stp = ↑structure;
ctp = ↑identifier;
structure = PACKED RECORD
selfstp: stp; size: addrrange;
nocode: boolean; bitsize: bitrange;
CASE form: structform OF
scalar: (CASE scalkind: declkind OF
declared: (db0: bits6; fconst: ctp;
vectoraddr, vectorchain: addrrange;
dimension: integer; nextscalar: stp;
request: boolean; tlev: levrange));
subrange: (db1: bits7; rangetype: stp; vmin, vmax: valu);
pointer: (db2: bits7; eltype: stp);
power: (db3: bits7; elset: stp);
arrays: (arraypf: boolean; db4: bits6; arraybpaddr: addrrange;
aeltype, inxtype: stp);
records: (recordpf: boolean; db5: bits6;
fstfld: ctp; recvar: stp);
files: (db6: bits6; filepf: boolean; filtype: stp;
file←form: fileformrange; file←mode: filemoderange);
tagfwithid,
tagfwithoutid: (db7: bits7; fstvar: stp;
CASE boolean OF
true : (tagfieldp: ctp);
false: (tagfieldtype: stp));
variant: (db9: bits7; nxtvar, subvar: stp; firstfield: ctp; varval: valu)
END;
btp = ↑bytepoint;
bytepoint = PACKED RECORD
last: btp;
arraysp: stp;
bitsize: bitrange
END;
gtp = ↑globptr;
globptr = RECORD
nextglobptr: gtp ;
firstglob,
lastglob : addrrange ;
fcix : coderange
END ;
ftp = ↑filblck;
filblck = PACKED RECORD
nextftp : ftp ;
fileident : ctp
END ;
ptp = ↑programparameter;
programparameter = PACKED RECORD
nextptp: ptp;
fileidptr: ctp;
fileid: alfa;
inputfile: boolean
END;
(*NAMES*)
(*******)
scalarform = (integerform,charform,realform,boolform,declaredform);
idclass = (types,konst,vars,field,proc,func,labels);
setofids = SET OF idclass;
idkind = (actual,formal);
packkind = (notpack,packk,hwordr,hwordl);
identifier = PACKED RECORD
name: alfa;
llink, rlink: ctp;
idtype: stp; next: ctp;
selfctp: ctp; nocode: boolean;
CASE klass: idclass OF
konst: (values: valu);
vars: (vkind: idkind;
vlev: levrange;
channel: acrange;
vdummy1: bits5;
vdummy2: bits18;
vaddr: addrrange);
field: (CASE packf: packkind OF
notpack,
hwordl,
hwordr: (hdummy: bits12; fldaddr: addrrange);
packk: (pdummy: bits12; fldbyte: bpointer));
proc,
func: (CASE pfdeckind: declkind OF
standard: (key: keyrange);
declared: (pflev: levrange;
parlistsize,pfaddr: addrrange;
highest←register: acrange;
CASE pfkind: idkind OF
actual: (forwdecl: boolean;
externdecl: boolean;
activated: boolean;
pfchain:ctp;
language: symbol;
testfwdptr: ctp;
externalname: alfa;
linkchain: PACKED ARRAY[levrange] OF addrrange);
formal: (fparam:ctp)));
labels:(scope: levrange;
jump←index: 0..jump←max;
exit←jump: boolean;
goto←chain: addrrange;
label←address: addrrange)
END;
disprange = 0..displimit;
where = (blck (* ID IS VARIABLE ID*)
,crec (* ID IS FIELD ID OF RECORD WITH CONSTANT ADDRESS*)
,vrec (* ID IS FIELD ID OF RECORD WITH VARIABLE ADDRESS*)
);
(*RELOCATION*)
(************)
coderefs = (noref,constref,externref,forwardref,gotoref,pointref,noinstr,saveref,debugref);
relbyte = (no,right,left,both);
relword = PACKED ARRAY[0..17] OF relbyte;
supports = ( stackoverflow, errorinassignment, indexerror, overflow, inputerror,
errorinset, nocoreavailable,
allocate, free,
exitprogram, runprogram, readpgmparameter,
resetfile, rewritefile, opentty, fortranreset, fortranexit, closefile,
getcharacter, getfile, getline, putfile, putline, putpage, putbuffer,
initializedebug, enterdebug, loaddebug,
convertintegertoreal,
asciitime, asciidate,
readreal, readinteger, readcharacter, readstring, readpackedstring,
writecharacter, writedefcharacter,
writestring, writedefstring,
writepackedstring, writedefpackedstring,
writeboolean, writedefboolean,
writereal, writedef1real, writedef2real,
writeinteger, writedefinteger,
writehexadecimal, writedefhexadecimal,
writeoctal, writedefoctal,
readirange, readcrange, readrrange,
readscalar,
readiset, readcset, readdset,
wrtscalar,
wrtiset, wrtcset, wrtdset,
startclock, showruntime, badpointer, (* 12. 21.*)
readpseudostring, (* 25.*)
writepseudostring,writedefpseudostring); (* 25.*)
(*EXPRESSIONS*)
(*************)
attrkind = (cst,varbl,expr);
attr = RECORD
typtr: stp;
CASE kind: attrkind OF
cst: (cval: valu);
varbl: (packfg: packkind;
indexr: acrange;
indbit: ibrange;
vlevel: levrange;
bpaddr,dplmt: addrrange;
vrelbyte: relbyte;
subkind: stp;
vclass: idclass;
vbyte: bpointer);
expr: (reg:acrange)
END;
testp = ↑ testpointer;
testpointer = PACKED RECORD
elt1,elt2: stp;
lasttestp: testp
END;
(*OTHER TYPES:*)
(**************)
write←form = (write←entry,write←name,write←hiseg,write←globals,write←code,write←internals,write←library,
write←debug,write←fileblocks,write←symbols,write←start,write←end);
namekind = (stdconst,stdfile,stdproc,stdfunc,declproc,declfunc);
btpkind = (unused,requested,calculated,used);
etp = ↑ errorwithtext;
errorwithtext = PACKED RECORD
number: integer;
next: etp;
string: alfa
END;
ksp = ↑ konstrec;
konstrec = PACKED RECORD
addr, kaddr: addrrange;
constptr: csp;
nextkonst: ksp;
double←chain: boolean
END;
pdp10instr = PACKED RECORD
instr : instrange ;
ac : acrange;
indbit : ibrange;
inxreg : acrange;
address : addrrange
END ;
change←form=(intcst,pdp10code,realcst,strcst,sixbitcst,halfwd,pdp10bp,radix) ;
charword = PACKED ARRAY[1..5] OF char;
halfs = PACKED RECORD
lefthalf: addrrange;
righthalf: addrrange
END;
codepointer = ↑codearray;
codearray = RECORD
CASE change←form OF
pdp10code: (instruction: ARRAY[coderange] OF pdp10instr);
intcst: (word: ARRAY[coderange] OF integer);
halfwd: (halfword: ARRAY[coderange] OF halfs)
END;
relpointer = ↑relarray;
relarray = PACKED ARRAY[coderange] OF relbyte;
refpointer = ↑refarray;
refarray = PACKED ARRAY[coderange] OF coderefs;
bufferpointer = ↑commandbuffer;
commandbuffer = PACKED ARRAY[0..buffer←size] OF ascii;
pageelem = PACKED RECORD
word1: pdp10instr;
lhalf: addrrange; rhalf: addrrange
END;
debentry = RECORD
lastpageelem: pageelem;
globalidtree: addrrange;
standardidtree: addrrange;
intpoint: stp;
realpoint: stp;
boolpoint: stp;
charpoint: stp
END;
nlk = ↑newlinks;
newlinks = PACKED RECORD
reftype : stp;
refadr : addrrange;
next : nlk;
END;
(* 25. FOR COMPILER-GENERATED PARAMETERS FOR THE SSTRING PROCEDURES.*)
sstrptr = ↑sstringparlength;
sstringparlength = PACKED RECORD
count: 0..2;
value: ARRAY[1..2] OF 1..xtrastrglgth;
next: sstrptr;
END;
(* declarations needed to bootstrap: used in the header of procedures for program
* parameter management *)
pack3 = packed array[1..3] of char;
pack6 = packed array[1..6] of char;
pack9 = packed array[1..9] of char;
anyfile = text;
(* end of bootstrapping declarations *)
(*------------------------------------------------------------------------------*)
VAR
(*VALUES RETURNED BY SOURCE PROGRAM SCANNER INSYMBOL:*)
(*****************************************************)
sy: symbol; (*LAST SYMBOL*)
op: operator; (*CLASSIFICATION OF LAST SYMBOL*)
val: valu; (*VALUE OF LAST CONSTANT*)
lgth: integer; (*LENGTH OF LAST STRING CONSTANT*)
id: alfa; (*LAST IDENTIFIER (POSSIBLY TRUNCATED)
OR LAST INTEGER CONST (FOR LABEL PROCESSING)*)
ch: char; (*LAST CHARACTER*)
(*COUNTERS:*)
(***********)
i, j: integer;
entries: integer;
support←index: supports;
language←index: symbol;
chcntmax: 0..stdchcntmax;
chcnt: 0..stdchcntmax; (*CHARACTER COUNTER*)
codeend, (*FIRST LOCATION NOT USED FOR INSTRUCTIONS*)
lcmain, lc,ic: addrrange; (*DATA LOCATION AND INSTRUCTION COUNTER*)
program←count: integer;
(*SWITCHES:*)
(***********)
dp, (*DECLARATION PART*)
reset←possible, (*TO IGNORE SWITCHES WHICH MUST NOT BE RESET*)
search←error, (*TO ALLOW FORWARD REFERENCES IN POINTER TYPE
DECLARATION BY SUPPRESSING ERROR MESSAGE*)
external, (*IF TRUE, ALL LEVEL-1 PROC/FUNC MAY BE
DECLARED AS "EXTERN" BY OTHER PROGRAMS*)
ttyread, (*TO INHIBIT TTYOPEN ('*'-PROMPTING) IF NO TTY-INPUT REQUESTED*)
outputwrite, (* 13. TO INHIBIT REWRITE OF OUTPUT IF NOT USED*)
inputpar, (* 13. TO INHIBIT RESET OF INPUT IF IT IS A PROGRAM PARAMETER.*)
outputpar, (* 13. SAME FOR OUTPUT.*)
debug, (*ENABLE DEBUGGING*)
debug←switch, (*TO GENERATE DEBUG INFORMATION*)
list←code, (*LIST MACRO CODE*)
lptfile, (*TO INHIBIT GENERATION OF LIST-FILE*)
initglobals, (*INITIALIZE GLOBAL VARIABLES*)
loadnoptr, (*IF TRUE, NO POINTERVARIABLE SHALL BE LOADED*)
fortran←enviroment,
load←and←go,
cross←reference,
resettty, (*IF TRUE, TTY WILL BE RESET AT PROGRAM START.*)
runtime←check, (*IF TRUE, PERFORM RUNTIME-TESTS*)
incondcomp, (*TRUE WHEN INSIDE A CONDITIONALLY-COMPILED PART*) (* 8.*)
parsingparameters, (* 25. TRUE WHEN CALL←NON←STANDARD IS PARSING THE PARAMETERS.*)
recall, (* 25. FOR COMPTYPES TO AVOID COUNTING TWICE WHEN RECURSING.*)
first←symbol: boolean;
(*POINTERS:*)
(***********)
sexternpfptr,
localpfptr, externpfptr: ctp; (*PTRS TO LOCAL/EXTERNAL PROC/FUNC-CHAIN*)
parmptr: ptp; (*PTR TO PROGRAMPARM.-CHAIN*)
stdfileptr: ARRAY[1..4] OF ctp; (*PTRS TO STD-FILES*)
sstringptr, strgrngptr, (* 25. PREDEFINED STRING AND 1..135 TYPES *)
strgrng0ptr, (* 25. PREDEFINED TYPE 0..135 *)
packc135ptr, (* 25. FOR THE TYPE OF STRTEXT IN STRING.*)
packc1ptr, (* 25. TO CONVERT CHARACTERS TO STRING CONSTANTS.*)
packc0ptr, (* 25. FOR THE CONSTANT NULLSTR.*)
alfaptr,packc9ptr,
packc3ptr,packc5ptr,asciiptr,
packc6ptr,packc8ptr,
intptr,realptr,charptr,
boolptr,nilptr,textptr: stp; (*POINTERS TO ENTRIES OF STANDARD IDS*)
sdeclscalptr,
declscalptr: stp; (*PTR TO CHAIN OF DECLARED SCALARS*)
utypptr,ucstptr,uvarptr,
ufldptr,uprcptr,ufctptr, (*POINTERS TO ENTRIES FOR UNDECLARED IDS*)
forward←pointer←type: ctp; (*HEAD OF CHAIN OF FORW DECL TYPE IDS*)
errmptr, errmptr1: etp; (*TO CHAIN ERRORS WITH TEXT*)
last←label: ctp; (*TOP OF LABEL CHAIN*)
slastbtp,
lastbtp: btp; (*HEAD OF BYTEPOINTERTABLE*)
sfileptr,
fileptr: ftp;
firstkonst: ksp;
anyfileptr: stp; (*TO ALLOW FILES OF "ANY" TYPE AS
VAR PARAMETERS IN STAND. PROC/FUNC*)
fglobptr,cglobptr : gtp ; (*POINTER TO FIRST AND CURRENT GLOBAL INITIALISATION RECORD*)
globtestp : testp ; (*POINTER TO LAST PAIR OF POINTERTYPES*)
globnewlink : nlk ; (*POINTER TO NEW-LINKS*)
(*BOOKKEEPING OF DECLARATION LEVELS:*)
(************************************)
level: levrange; (*CURRENT STATIC LEVEL*)
disx, (*LEVEL OF LAST ID SEARCHED BY SEARCHID*)
top: disprange; (*TOP OF DISPLAY*)
display: ARRAY[disprange] OF
PACKED RECORD
fname: ctp;
CASE occur: where OF
crec: (clev: levrange;
cindr: acrange;
cindb: ibrange;
crelbyte: relbyte;
cdspl,
clc : addrrange)
END;
(*ERROR MESSAGES:*)
(*****************)
error←flag: boolean; (*TRUE IF SYNTACTIC ERRORS DETECTED IN ONE PROGRAM*)
no←code←gen: boolean; (*IF TRUE, WRITE←MACHINE←CODE WILL NOT EXECUTE*)
(*SET BY ANY ERRORS OR BY /NOLOAD IN PASSGO*)
error←in←heading: boolean;
errinx: 0..maxerr ; (*NR OF ERRORS IN CURRENT SOURCE LINE*)
errorcount: integer; (*TOTAL NR OF ERRORS DETECTED IN PROGRAM*)
error←exit: boolean; (*TO ENABLE EXIT DURING COMPILATION*)
overrun: boolean;
errlist:
ARRAY [1..maxerr] OF
PACKED RECORD
arw: 1..maxerr;
pos: 1..stdchcntmax;
nmr: 1..600;
tic: char
END;
errmess15 : ARRAY [1..24] OF PACKED ARRAY [1..15] OF char;
errmess20 : ARRAY [1..15] OF PACKED ARRAY [1..20] OF char;
errmess25 : ARRAY [1..18] OF PACKED ARRAY [1..25] OF char;
errmess30 : ARRAY [1..21] OF PACKED ARRAY [1..30] OF char;
errmess35 : ARRAY [1..17] OF PACKED ARRAY [1..35] OF char;
errmess40 : ARRAY [1..13] OF PACKED ARRAY [1..40] OF char;
errmess45 : ARRAY [1..19] OF PACKED ARRAY [1..45] OF char;
errmess50 : ARRAY [1..10] OF PACKED ARRAY [1..50] OF char;
errmess55 : ARRAY [1.. 8] OF PACKED ARRAY [1..55] OF char;
errorinline,
followerror : boolean;
errline,
buffer: ARRAY [1..stdchcntmax] OF char;
firstpage, (* 6. PAGE AT WHICH THE PROGRAM STARTS. *)
pagecnt,
linecnt: integer;
linenr: PACKED ARRAY [1..5] OF char;
(*EXPRESSION COMPILATION:*)
(*************************)
gattr: attr; (*DESCRIBES THE EXPR CURRENTLY COMPILED*)
aos: (b0,b1,b2,b3,aosinstr,sosinstr); (*TESTS CONDITION FOR AOS/SOS-INSTRUCTION*)
leftside: attr; (*LEFT SIDE OF ASSIGNMENT*)
(*COMPILATION OF PACKED STRUCTURES:*)
(***********************************)
arraybps: ARRAY[1:18] OF
RECORD
abyte: bpointer; bytemax: bitrange;
address: addrrange;
state: btpkind
END;
(*DEBUG-SYSTEM:*)
(***************)
laststop: addrrange; (*LAST BREAKPOINT*)
lastline, (*LINENUMBER FOR BREAKPOINTS*)
linediff, (*DIFFERENCE BETWEEN ↑ AND LINECNT*)
lastpage:integer; (*LAST PAGE THAT CONTAINS A STOP*)
pageheadadr, (*OVERGIVE TO DEBUG.PAS*)
lastpager: addrrange; (*POINTS AT LAST PAGERECORD*)
pager: pageelem; (*ACTUAL PAGERECORD*)
debentry←size: integer; (*DEBENTRY LENGTH *)
debugentry: debentry;
idrecsize: ARRAY[idclass] OF integer;
strecsize: ARRAY[structform] OF integer;
(*STRUCTURED CONSTANTS:*)
(***********************)
lettersordigits,letters,digits,lettersdigitsorleftarrow,hexadigits: SET OF char;
constbegsys,simptypebegsys,typebegsys,blockbegsys,selectsys,facbegsys,
languagesys,statbegsys,typedels: setofsys;
rw: ARRAY [1..rswmax] OF alfa;
frw: ARRAY [1..11(*ALFALENGTH+1*)] OF 1..rswmaxp1;
rsy: ARRAY [1..rswmax] OF symbol;
ssy: ARRAY [' '..'←'] OF symbol;
rop: ARRAY [1..rswmax] OF operator;
sop: ARRAY [' '..'←'] OF operator;
na: ARRAY[namekind] OF ARRAY[1..stdmax] OF alfa; (* PASCAL NAMES OF THE KNOWN RUNTIMES.*)
namax: ARRAY[namekind] OF integer; (* NUMBER OF NAMES IN NA FOR EACH FIRST SUBSCRIPT.*)
extna: ARRAY[declproc..declfunc] OF ARRAY[1..extpfmax] OF alfa; (* SIX-LETTER NAMES OF THOSE RUNTIMES.*)
extlanguage: ARRAY[declproc..declfunc] OF ARRAY[1..extpfmax] OF symbol; (* FOR CALLING CONVENTIONS.*)
mnemonics : ARRAY[1..45] OF PACKED ARRAY[1..60] OF char ;
showibit : ARRAY[ibrange] OF char;
showrelo : ARRAY[boolean] OF char;
showref : ARRAY[coderefs] OF char;
write←support, read←support: ARRAY[scalarform,scalar..power] OF supports;
(*LABEL PROCESSING:*)
(*******************)
jumper: 0..jump←max;
jump←table: PACKED ARRAY[jump←range] OF addrrange;
jump←address: addrrange;
(*OTHER VARIABLES:*)
(********************)
relocation←block: PACKED RECORD
CASE integer OF
1: (component: ARRAY[1..20] OF integer);
2: (item: addrrange; count: addrrange;
relocator: relword;
code: ARRAY[0..17] OF integer)
END;
runtime←support: PACKED RECORD
name: ARRAY[supports] OF alfa;
link: PACKED ARRAY[supports] OF addrrange
END;
code←array: codepointer;
code←reference: refpointer;
command←buffer: bufferpointer;
code←relocation: relpointer;
change : PACKED RECORD
CASE change←form OF
intcst :(wkonst: integer);
pdp10code:(winstr: pdp10instr);
realcst :(wreal: real);
strcst :(wstring: charword);
sixbitcst:(wsixbit: PACKED ARRAY[1..6] OF 0..77B);
halfwd :(wlefthalf: addrrange ; wrighthalf : addrrange);
pdp10bp :(wbyte: bpointer);
radix :(flag: flagrange; symbol: radixrange)
END;
regc, (*TOP OF REGISTERSTACK*)
regcmax: acrange; (*MAXIMUM OF REGISTERS FOR EXPRESSION STACK*)
cix, (*CODE-ARRAY INDEX*)
stacksize1, stacksize2, (*TO INSERT LCMAX IN PROCEDURE/FUNCTION ENTRY CODE*)
pfstart: integer; (*START OF NORMAL ENTRYCODE OF EACH FUNC. OR PROC.*)
lcmax: addrrange; lcp: ctp;
tempcore, source, list : text;
object: FILE OF integer; (*26. A FAKE REL FILE FOR DEBUGGING OF PASSGO*)
withix: integer; (*TOP OF WITH-REG STACK*)
highest←code, (*HIGH SEG. BREAK*)
main←start, (*START OF BODY OF MAIN*)
idtree, (*POINTER TO THE IDENTIFIER-TREE*)
name←address, (*ADDR OF PROGRAM-NAME(ALFA-STRING)*)
start←address: addrrange; (*STARTADDRESS*)
lparmptr, backwparmptr: ptp;
day, timeofday, programname: alfa;
entry: ARRAY[0..entrymax] OF alfa;
object←file,
source←file, list←file: PACKED ARRAY [1..9] OF char;
(* 23. RUNTIME REPORTED BY THE LIBRARY PROCEDURES.*)
core: ARRAY[1..2] OF integer;
goodversion, (*VERSION NUMBER TO BE CONDITIONALLY COMPILED*) (* 8.*)
start←channel, code←size, runcore, parregcmax: integer;
entry←done: boolean;
(* 25. STRING LENGTH FOR CALL OF STRING-MANAGING PROCEDURES.*)
sstringstart: boolean;
sstringlength: sstrptr;
pctp : ctp;
suptindex: supports; (* 26.*)
(* 4. ALLOW FOR FLEXIBLE NAME OF PCROSS FILE; KEEP TABLE OF PCROSS SWITCHES.*)
pcross←file,
pcross←tmpfile: PACKED ARRAY [1..9] OF char;
pcross←device: PACKED ARRAY[1..6] OF char;
pcross←ppn, pcross←core: integer;
pcross←option←name: PACKED ARRAY [1..maxpcrossoption] OF alfa;
(* 1. ALLOW FOR FLEXIBLE NAME OF LINKER-LOADER.*)
linker←file,
link←tmpfile: PACKED ARRAY[1..9] OF char;
link←device: PACKED ARRAY[1..6] OF char;
link←ppn: integer;
library←index: integer;
library←order: PACKED ARRAY[1..4] OF symbol;
library: ARRAY[pascalsy..fortransy] OF RECORD
chained, called: boolean;
name: alfa;
projnr: addrrange;
prognr: addrrange;
device: alfa
END;
(*------------------------------------------------------------------------------*)
(* INITPROCEDURES. *)
INITPROCEDURE (* MNEMONICS *) ;
BEGIN
mnemonics[ 1] := '***001***002***003***004***005***006***007***010***011***012' ;
mnemonics[ 2] := '***013***014***015***016***017***020***021***022***023***024' ;
mnemonics[ 3] := '***025***026***027***030***031***032***033***034***035***036' ;
mnemonics[ 4] := '***037CALL INIT ***042***043***044***045***046CALLI OPEN ' ;
mnemonics[ 5] := 'TTCALL***052***053***054RENAMEIN OUT SETSTSSTATO STATUS' ;
mnemonics[ 6] := 'STATZ INBUF OUTBUFINPUT OUTPUTCLOSE RELEASMTAPE UGETF USETI ' ;
mnemonics[ 7] := 'USETO LOOKUPENTER UJEN ***101***102***103***104***105***106' ;
mnemonics[ 8] := '***107***110***111***112***113***114***115***116***117***120' ;
mnemonics[ 9] := '***121***122***123***124***125***126***127UFA DFN FSC ' ;
mnemonics[10] := 'IBP ILDB LDB IDPB DPB FAD FADL FADM FADB FADR ' ;
mnemonics[11] := 'FADRI FADRM FADRB FSB FSBL FSBM FSBB FSBR FSBRI FSBRM ' ;
mnemonics[12] := 'FSBRB FMP FMPL FMPM FMPB FMPR FMPRI FMPRM FMPRB FDV ' ;
mnemonics[13] := 'FDVL FDVM FDVB FDVR FDVRI FDVRM FDVRB MOVE MOVEI MOVEM ' ;
mnemonics[14] := 'MOVES MOVS MOVSI MOVSM MOVSS MOVN MOVNI MOVNM MOVNS MOVM ' ;
mnemonics[15] := 'MOVMI MOVMM MOVMS IMUL IMULI IMULM IMULB MUL MULI MULM ' ;
mnemonics[16] := 'MULB IDIV IDIVI IDIVM IDIVB DIV DIVI DIVM DIVB ASH ' ;
mnemonics[17] := 'ROT LSH JFFO ASHC ROTC LSHC ***247EXCH BLT AOBJP ' ;
mnemonics[18] := 'AOBJN JRST JFCL XCT ***257PUSHJ PUSH POP POPJ JSR ' ;
mnemonics[19] := 'JSP JSA JRA ADD ADDI ADDM ADDB SUB SUBI SUBM ' ;
mnemonics[20] := 'SUBB CAI CAIL CAIE CAILE CAIA CAIGE CAIN CAIG CAM ' ;
mnemonics[21] := 'CAML CAME CAMLE CAMA CAMGE CAMN CAMG JUMP JUMPL JUMPE ' ;
mnemonics[22] := 'JUMPLEJUMPA JUMPGEJUMPN JUMPG SKIP SKIPL SKIPE SKIPLESKIPA ' ;
mnemonics[23] := 'SKIPGESKIPN SKIPG AOJ AOJL AOJE AOJLE AOJA AOJGE AOJN ' ;
mnemonics[24] := 'AOJG AOS AOSL AOSE AOSLE AOSA AOSGE AOSN AOSG SOJ ' ;
mnemonics[25] := 'SOJL SOJE SOJLE SOJA SOJGE SOJN SOJG SOS SOSL SOSE ' ;
mnemonics[26] := 'SOSLE SOSA SOSGE SOSN SOSG SETZ SETZI SETZM SETZB AND ' ;
mnemonics[27] := 'ANDI ANDM ANDB ANDCA ANDCAIANDCAMANDCABSETM SETMI SETMM ' ;
mnemonics[28] := 'SETMB ANDCM ANDCMIANDCMMANDCMBSETA SETAI SETAM SETAB XOR ' ;
mnemonics[29] := 'XORI XORM XORB IOR IORI IORM IORB ANDCB ANDCBIANDCBM' ;
mnemonics[30] := 'ANDCBBEQV EQVI EQVM EQVB SETCA SETCAISETCAMSETCABORCA ' ;
mnemonics[31] := 'ORCAI ORCAM ORCAB SETCM SETCMISETCMMSETCMBORCM ORCMI ORCMM ' ;
mnemonics[32] := 'ORCMB ORCB ORCBI ORCBM ORCBB SETO SETOI SETOM SETOB HLL ' ;
mnemonics[33] := 'HLLI HLLM HLLS HRL HRLI HRLM HRLS HLLZ HLLZI HLLZM ' ;
mnemonics[34] := 'HLLZS HRLZ HRLZI HRLZM HRLZS HLLO HLLOI HLLOM HLLOS HRLO ' ;
mnemonics[35] := 'HRLOI HRLOM HRLOS HLLE HLLEI HLLEM HLLES HRLE HRLEI HRLEM ' ;
mnemonics[36] := 'HRLES HRR HRRI HRRM HRRS HLR HLRI HLRM HLRS HRRZ ' ;
mnemonics[37] := 'HRRZI HRRZM HRRZS HLRZ HLRZI HLRZM HLRZS HRRO HRROI HRROM ' ;
mnemonics[38] := 'HRROS HLRO HLROI HLROM HLROS HRRE HRREI HRREM HRRES HLRE ' ;
mnemonics[39] := 'HLREI HLREM HLRES TRN TLN TRNE TLNE TRNA TLNA TRNN ' ;
mnemonics[40] := 'TLNN TDN TSN TDNE TSNE TDNA TSNA TDNN TSNN TRZ ' ;
mnemonics[41] := 'TLZ TRZE TLZE TRZA TLZA TRZN TLZN TDZ TSZ TDZE ' ;
mnemonics[42] := 'TSZE TDZA TSZA TDZN TSZN TRC TLC TRCE TLZE TRCA ' ;
mnemonics[43] := 'TLCA TRCN TLCN TDC TSC TDCE TSCE TDCA TSCA TDCN ' ;
mnemonics[44] := 'TSCN TRO TLO TROE TLOE TROA TLOA TRON TLON TDO ' ;
mnemonics[45] := 'TSO TDOE TSOE TDOA TSOA TDON TSON ***700 ' ;
showibit[0] := ' '; showibit[1] := '@';
showrelo[false] := ' '; showrelo[true] := '''';
showref[noref] := ' '; showref[constref] := 'C';
showref[externref] := 'E'; showref[noinstr] := ' ';
showref[forwardref] := 'F'; showref[gotoref] := 'G';
showref[pointref] := 'P'; showref[saveref] := 'S';
showref[debugref] := 'D';
END (* MNEMONICS *) ;
INITPROCEDURE (*SEARCH LIBRARIES*) ;
BEGIN
(* INSERT (???) DEVICE, PROJNR, PROGNR AND CORE FOR PASLIB AND PCROSS *)
library[pascalsy].chained := false;
library[fortransy].chained := false;
library[pascalsy].called := false;
library[fortransy].called := false;
library[pascalsy].name := 'PASLIB ';
library[fortransy].name := 'FORLIB ';
library[pascalsy].device := 'SYS '; (* 0. *)
library[fortransy].device := 'SYS ';
library[pascalsy].projnr := 0;
library[fortransy].projnr := 0;
library[pascalsy].prognr := 0;
library[fortransy].prognr := 0;
(* 4. FLEXIBLE NAME FOR CROSS←REFERENCER*)
pcross←file := 'PCROSS ';
pcross←tmpfile := 'PCR TMP';
pcross←device := 'SYS '; (* 0.*)
pcross←ppn := 0;
pcross←core := 100;
(* 1. FLEXIBLE NAME FOR THE LINKER.*)
linker←file := 'LOADER ';
link←tmpfile := 'LOA TMP';
link←device := 'SYS ';
link←ppn := 0;
END (*SEARCH LIBRARIES*) ;
INITPROCEDURE (*STANDARD NAMES*) ;
BEGIN
na[stdfile, 1] := 'INPUT '; na[stdfile, 2] := 'OUTPUT '; na[stdfile, 3] := 'TTY ';
na[stdfile, 4] := 'TTYOUTPUT ';
na[stdproc, 1] := 'GET '; na[stdproc, 2] := 'GETLN '; na[stdproc, 3] := 'PUT ';
na[stdproc, 4] := 'PUTLN '; na[stdproc, 5] := 'RESET '; na[stdproc, 6] := 'REWRITE ';
na[stdproc, 7] := 'READ '; na[stdproc, 8] := 'READLN '; na[stdproc, 9] := 'BREAK ';
na[stdproc,10] := 'WRITE '; na[stdproc,11] := 'WRITELN '; na[stdproc,12] := 'PACK ';
na[stdproc,13] := 'UNPACK '; na[stdproc,14] := 'NEW '; na[stdproc,15] := '$$$1 ';
na[stdproc,16] := '$$$2 '; na[stdproc,17] := 'GETLINENR '; na[stdproc,18] := '$$$3 ';
na[stdproc,19] := 'PAGE '; na[stdproc,20] := 'PROTECTION'; na[stdproc,21] := 'CALL ';
na[stdproc,22] := 'DATE '; na[stdproc,23] := 'TIME '; na[stdproc,24] := 'DISPOSE ';
na[stdproc,25] := 'HALT '; na[stdproc,26] := 'GETSEG '; na[stdproc,27] := 'PUTSEG ';
na[stdproc,28] := 'MESSAGE '; na[stdproc,29] := 'LINELIMIT ';
na[stdfunc, 1] := 'REALTIME '; na[stdfunc, 2] := 'ABS '; na[stdfunc, 3] := 'SQR ';
na[stdfunc, 4] := '$$$4 '; na[stdfunc, 5] := 'ODD '; na[stdfunc, 6] := 'ORD ';
na[stdfunc, 7] := 'CHR '; na[stdfunc, 8] := 'PRED '; na[stdfunc, 9] := 'SUCC ';
na[stdfunc,10] := 'EOF '; na[stdfunc,11] := 'EOLN '; na[stdfunc,12] := 'CLOCK ';
na[stdfunc,13] := 'CARD '; na[stdfunc,14] := '$$$5 '; na[stdfunc,15] := 'LOWERBOUND';
na[stdfunc,16] := 'UPPERBOUND'; na[stdfunc,17] := 'EOS '; na[stdfunc,18] := '$$$6 ';
na[stdfunc,19] := 'MIN '; na[stdfunc,20] := 'MAX '; na[stdfunc,21] := 'FIRST ';
na[stdfunc,22] := 'LAST ';
na[declfunc, 1] := 'COS '; na[declfunc, 2] := 'EXP '; na[declfunc, 3] := 'SQRT ';
na[declfunc, 4] := 'LN '; na[declfunc, 5] := 'ARCTAN '; na[declfunc, 6] := 'LOG ';
na[declfunc, 7] := 'SIND '; na[declfunc, 8] := 'COSD '; na[declfunc, 9] := 'SINH ';
na[declfunc,10] := 'COSH '; na[declfunc,11] := 'TANH '; na[declfunc,12] := 'ARCSIN ';
na[declfunc,13] := 'ARCCOS '; na[declfunc,14] := 'RANDOM '; na[declfunc,15] := 'SIN ';
na[declfunc,16] := 'ROUND '; na[declfunc,17] := 'EXPO '; na[declfunc,18] := 'OPTION ';
na[declfunc,19] := '$$$7 '; na[declfunc,20] := 'TRUNC '; na[declfunc,21] := 'LENGTH '; (* 25.*)
na[declfunc,22] := 'GETCHAR '; na[declfunc,23] := 'POS '; na[declfunc,24] := 'STRLT '; (* 25.*)
na[declfunc,25] := 'STRLE '; na[declfunc,26] := 'STREQ '; na[declfunc,27] := 'STRGE '; (* 25.*)
na[declfunc,28] := 'STRGT '; na[declfunc,29] := 'STRNE '; (* 25.*)
na[stdconst, 1] := 'FALSE '; na[stdconst, 2] := 'TRUE '; na[stdconst, 3] := 'NUL ';
na[stdconst, 4] := 'SOH '; na[stdconst, 5] := 'STX '; na[stdconst, 6] := 'ETX ';
na[stdconst, 7] := 'EOT '; na[stdconst, 8] := 'ENQ '; na[stdconst, 9] := 'ACK ';
na[stdconst,10] := 'BEL '; na[stdconst,11] := 'BS '; na[stdconst,12] := 'HT ';
na[stdconst,13] := 'LF '; na[stdconst,14] := 'VT '; na[stdconst,15] := 'FF ';
na[stdconst,16] := 'CR '; na[stdconst,17] := 'SO '; na[stdconst,18] := 'SI ';
na[stdconst,19] := 'DLE '; na[stdconst,20] := 'DC1 '; na[stdconst,21] := 'DC2 ';
na[stdconst,22] := 'DC3 '; na[stdconst,23] := 'DC4 '; na[stdconst,24] := 'NAK ';
na[stdconst,25] := 'SYN '; na[stdconst,26] := 'ETB '; na[stdconst,27] := 'CAN ';
na[stdconst,28] := 'EM '; na[stdconst,29] := 'SUB '; na[stdconst,30] := 'ESC ';
na[stdconst,31] := 'FS '; na[stdconst,32] := 'GS '; na[stdconst,33] := 'RS ';
na[stdconst,34] := 'US '; na[stdconst,35] := 'SP '; na[stdconst,36] := 'DEL ';
na[declproc, 1] := 'GETFILENAM'; na[declproc, 2] := 'GETOPTION '; na[declproc, 3] := 'GETSTATUS ';
(* 7. NEW RUNTIMES FROM THE CCL SCANNER.*)
na[declproc, 4] := 'ASKFILENAM'; na[declproc, 5] := 'STARTFILE '; na[declproc, 6] := 'GETPARAMET';
na[declproc, 7] := 'GETNEXTCAL'; na[declproc, 8] := 'FILNAM '; na[declproc, 9] := 'REENTER ';
na[declproc,10] := 'SETTIME '; na[declproc,11] := 'TIMEREPORT'; na[declproc,12] := 'RUNTIME ';
na[declproc,13] := 'ELAPSEDTIM'; na[declproc,14] := 'PUTCHAR '; na[declproc,15] := 'ASSIGN '; (* 25.*)
na[declproc,16] := 'SUBSTR '; na[declproc,17] := 'CONCAT '; (* 25.*)
namax[stdfile] := 4; namax[stdproc] := 29; namax[stdfunc] := 22; (* 25.*)
namax[declfunc] := 29; namax[declproc] := 17; namax[stdconst] := 36; (* 25.*)
END (*STANDARD NAMES*) ;
INITPROCEDURE (*EXTERNAL PROCEDURE/FUNCTION NAMES*);
BEGIN
extna[declfunc, 1] := 'COS '; extlanguage[declfunc, 1] := fortransy;
extna[declfunc, 2] := 'EXP '; extlanguage[declfunc, 2] := fortransy;
extna[declfunc, 3] := 'SQRT '; extlanguage[declfunc, 3] := fortransy;
extna[declfunc, 4] := 'ALOG '; extlanguage[declfunc, 4] := fortransy;
extna[declfunc, 5] := 'ATAN '; extlanguage[declfunc, 5] := fortransy;
extna[declfunc, 6] := 'ALOG10 '; extlanguage[declfunc, 6] := fortransy;
extna[declfunc, 7] := 'SIND '; extlanguage[declfunc, 7] := fortransy;
extna[declfunc, 8] := 'COSD '; extlanguage[declfunc, 8] := fortransy;
extna[declfunc, 9] := 'SINH '; extlanguage[declfunc, 9] := fortransy;
extna[declfunc,10] := 'COSH '; extlanguage[declfunc,10] := fortransy;
extna[declfunc,11] := 'TANH '; extlanguage[declfunc,11] := fortransy;
extna[declfunc,12] := 'ASIN '; extlanguage[declfunc,12] := fortransy;
extna[declfunc,13] := 'ACOS '; extlanguage[declfunc,13] := fortransy;
extna[declfunc,14] := 'RAN '; extlanguage[declfunc,14] := fortransy;
extna[declfunc,15] := 'SIN '; extlanguage[declfunc,15] := fortransy;
extna[declfunc,16] := 'ROUND '; extlanguage[declfunc,16] := pascalsy;
extna[declfunc,17] := 'EXPO '; extlanguage[declfunc,17] := pascalsy;
extna[declfunc,18] := 'OPTION '; extlanguage[declfunc,18] := pascalsy;
extna[declfunc,19] := 'UNDEFI '; extlanguage[declfunc,19] := pascalsy;
extna[declfunc,20] := 'TRUNC '; extlanguage[declfunc,20] := pascalsy;
extna[declfunc,21] := 'LENGTH '; extlanguage[declfunc,21] := pascalsy; (* 25.*)
extna[declfunc,22] := 'GETCHA '; extlanguage[declfunc,22] := pascalsy; (* 25.*)
extna[declfunc,23] := 'POS '; extlanguage[declfunc,23] := pascalsy; (* 25.*)
extna[declfunc,24] := 'STRLT '; extlanguage[declfunc,24] := pascalsy; (* 25.*)
extna[declfunc,25] := 'STRLE '; extlanguage[declfunc,25] := pascalsy; (* 25.*)
extna[declfunc,26] := 'STREQ '; extlanguage[declfunc,26] := pascalsy; (* 25.*)
extna[declfunc,27] := 'STRGE '; extlanguage[declfunc,27] := pascalsy; (* 25.*)
extna[declfunc,28] := 'STRGT '; extlanguage[declfunc,28] := pascalsy; (* 28.*)
extna[declfunc,29] := 'STRNE '; extlanguage[declfunc,29] := pascalsy; (* 25.*)
extna[declproc, 1] := 'GETFIL '; extlanguage[declproc, 1] := pascalsy;
extna[declproc, 2] := 'GETOPT '; extlanguage[declproc, 2] := pascalsy;
extna[declproc, 3] := 'GETSTA '; extlanguage[declproc, 3] := pascalsy;
(* 7. NEW RUNTIMES FROM THE CCL SCANNER.*)
extna[declproc, 4] := 'ASKFIL '; extlanguage[declproc, 4] := pascalsy;
extna[declproc, 5] := 'STARTF '; extlanguage[declproc, 5] := pascalsy;
extna[declproc, 6] := 'GETPAR '; extlanguage[declproc, 6] := pascalsy;
extna[declproc, 7] := 'GETNEX '; extlanguage[declproc, 7] := pascalsy;
extna[declproc, 8] := 'FILNAM '; extlanguage[declproc, 8] := pascalsy;
extna[declproc, 9] := 'REENTE '; extlanguage[declproc, 9] := pascalsy;
extna[declproc,10] := 'SETTIM '; extlanguage[declproc,10] := pascalsy;
extna[declproc,11] := 'TIMERE '; extlanguage[declproc,11] := pascalsy;
extna[declproc,12] := 'RUNTIM '; extlanguage[declproc,12] := pascalsy;
extna[declproc,13] := 'ELAPSE '; extlanguage[declproc,13] := pascalsy;
extna[declproc,14] := 'PUTCHA '; extlanguage[declproc,14] := pascalsy; (* 25.*)
extna[declproc,15] := 'ASSIGN '; extlanguage[declproc,15] := pascalsy; (* 25.*)
extna[declproc,16] := 'SUBSTR '; extlanguage[declproc,16] := pascalsy; (* 25.*)
extna[declproc,17] := 'CONCAT '; extlanguage[declproc,17] := pascalsy; (* 25.*)
END (*EXTERNAL PROCEDURE/FUNCTION NAMES*);
INITPROCEDURE (*RUNTIME-, DEBUG-SUPPORT NAMES*) ;
BEGIN
(* 13. REORDERED ACCORDING TO THE DECLARATION OF TYPE SUPPORTS.*)
runtime←support.name[stackoverflow] := 'CORERR ';
runtime←support.name[errorinassignment] := 'SRERR ';
runtime←support.name[indexerror] := 'INXERR ';
runtime←support.name[overflow] := 'OVERF. ';
runtime←support.name[inputerror] := 'IPTERR ';
runtime←support.name[errorinset] := 'SETERR ';
runtime←support.name[nocoreavailable] := 'NOCORE ';
runtime←support.name[allocate] := 'NEW ';
runtime←support.name[free] := 'FREE ';
runtime←support.name[exitprogram] := 'END ';
runtime←support.name[runprogram] := 'RUNPGM ';
runtime←support.name[readpgmparameter] := 'GETPAR ';
runtime←support.name[resetfile] := 'RESETF ';
runtime←support.name[rewritefile] := 'REWRIT ';
runtime←support.name[opentty] := 'TTYOPN ';
runtime←support.name[fortranreset] := 'RESET. ';
runtime←support.name[fortranexit] := 'EXIT. ';
runtime←support.name[closefile] := 'CLSFIL ';
runtime←support.name[getcharacter] := 'GETCH ';
runtime←support.name[getfile] := 'GET ';
runtime←support.name[getline] := 'GETLN ';
runtime←support.name[putfile] := 'PUT ';
runtime←support.name[putline] := 'PUTLN ';
runtime←support.name[putpage] := 'PUTPG ';
runtime←support.name[putbuffer] := 'PUTBUF ';
runtime←support.name[initializedebug] := 'INDEB. ';
runtime←support.name[enterdebug] := 'EXDEB. ';
runtime←support.name[loaddebug] := 'DEBUG ';
runtime←support.name[convertintegertoreal] := 'INTREA ';
runtime←support.name[asciitime] := 'TIME. ';
runtime←support.name[asciidate] := 'DATE. ';
runtime←support.name[readreal] := 'READR ';
runtime←support.name[readinteger] := 'READI ';
runtime←support.name[readcharacter] := 'READC ';
runtime←support.name[readstring] := 'READS ';
runtime←support.name[readpackedstring] := 'READPS ';
runtime←support.name[writecharacter] := 'WRITEC ';
runtime←support.name[writedefcharacter] := 'WRITC1 ';
runtime←support.name[writestring] := 'WRTUST ';
runtime←support.name[writedefstring] := 'WRTUS1 ';
runtime←support.name[writepackedstring] := 'WRTPST ';
runtime←support.name[writedefpackedstring] := 'WRTPS1 ';
runtime←support.name[writeboolean] := 'WRTBOL ';
runtime←support.name[writedefboolean] := 'WRTBO1 ';
runtime←support.name[writereal] := 'WRTREA ';
runtime←support.name[writedef1real] := 'WRTRE1 ';
runtime←support.name[writedef2real] := 'WRTRE2 ';
runtime←support.name[writeinteger] := 'WRTINT ';
runtime←support.name[writedefinteger] := 'WRTIN1 ';
runtime←support.name[writehexadecimal] := 'WRTHEX ';
runtime←support.name[writedefhexadecimal] := 'WRTHX1 ';
runtime←support.name[writeoctal] := 'WRTOCT ';
runtime←support.name[writedefoctal] := 'WRTOC1 ';
runtime←support.name[readirange] := 'READIR ';
runtime←support.name[readcrange] := 'READCR ';
runtime←support.name[readrrange] := 'READRR ';
runtime←support.name[readscalar] := 'READSC ';
runtime←support.name[readiset] := 'READIS ';
runtime←support.name[readcset] := 'READCS ';
runtime←support.name[readdset] := 'READDS ';
runtime←support.name[wrtscalar] := 'WRTSCA ';
runtime←support.name[wrtiset] := 'WRTISE ';
runtime←support.name[wrtcset] := 'WRTCSE ';
runtime←support.name[wrtdset] := 'WRTDSE ';
runtime←support.name[startclock] := 'SETTIM ';
runtime←support.name[showruntime] := 'TIMERE ';
runtime←support.name[badpointer] := 'PTRERR ';
runtime←support.name[readpseudostring] := 'READST '; (* 25.*)
runtime←support.name[writepseudostring] := 'WRTSTR '; (* 25.*)
runtime←support.name[writedefpseudostring] := 'WRTST1 '; (* 25.*)
read←support[integerform,subrange] := readirange;
read←support[integerform,power] := readiset;
read←support[integerform,scalar] := readinteger;
read←support[realform,subrange] := readrrange;
read←support[realform,scalar] := readreal;
read←support[charform,subrange] := readcrange;
read←support[charform,power] := readcset;
read←support[charform,scalar] := readcharacter;
read←support[declaredform,subrange] := readscalar;
read←support[declaredform,power] := readdset;
read←support[declaredform,scalar] := readscalar;
write←support[integerform,power] := wrtiset;
write←support[charform,power] := wrtcset;
write←support[declaredform,power] := wrtdset;
write←support[declaredform,subrange] := wrtscalar;
write←support[declaredform,scalar] := wrtscalar;
END (*RUNTIME-, DEBUG-SUPPORT NAMES*) ;
INITPROCEDURE (*INITSCALARS*) ;
BEGIN
programname := ' ';
forward←pointer←type := NIL; lastbtp := NIL; fglobptr := NIL ; fileptr := NIL ;
localpfptr := NIL; externpfptr := NIL; globtestp := NIL; last←label := NIL;
errmptr := NIL; parmptr := NIL; declscalptr := NIL; backwparmptr := NIL;
sdeclscalptr := NIL; sexternpfptr := NIL; sfileptr := NIL;
slastbtp := NIL; globnewlink := NIL;
list←code := false; loadnoptr := true; initglobals := false ; runtime←check := true;
followerror := false; errorinline := false; reset←possible := true; first←symbol := true;
dp := true; search←error := true; error←flag := false ; external := false;
no←code←gen := false;
entry←done := false; debug := false; debug←switch := false; lptfile := false;
error←exit := false; ttyread := false; load←and←go := false;
cross←reference := false; fortran←enviroment := false;
incondcomp := false; (* 8. INITIALLY OUT OF CONDITIONAL COMPILATION.*)
outputwrite := false; inputpar := false; outputpar := false; (* 13.*)
ic := high←start; (*START OF HIGHSEGMENT*)
lc := low←start; (*START OF LOWSEGMENT AVAILABLE TO PROGRAM*)
chcnt := 0; linecnt := 10; pagecnt := 1; lastline := -1;
aos := b0; library←index := 0; errinx := 0;
debugentry.standardidtree := 0; debugentry.globalidtree := 0; start←channel := 0;
parregcmax := stdparregcmax; chcntmax := stdchcntmax;
code←size := cixmax; runcore := 170B; jumper := 0; jump←address := 0;
errorcount := 0; entries := 0; program←count := 0;
lastpage := 0; goodversion := -1; (* 8. VERSION TO BE TAKEN.*)
END (*INITSCALARS*) ;
INITPROCEDURE (*INITSETS*) ;
BEGIN
digits := ['0'..'9'];
letters := ['A'..'Z'];
hexadigits := ['0'..'9','A'..'F'];
lettersordigits := [ '0'..'9','A'..'Z'];
lettersdigitsorleftarrow := ['0'..'9','A'..'Z','←'];
languagesys := [fortransy,pascalsy];
constbegsys := [addop,intconst,realconst,stringconst,ident];
simptypebegsys := [addop,intconst,realconst,stringconst,ident,lparent] ;
typebegsys := [addop,intconst,realconst,stringconst,ident,lparent,arrow,
packedsy,arraysy,recordsy,setsy,filesy,segmentsy] ; (* 13.*)
typedels := [arraysy,recordsy,setsy,filesy];
blockbegsys := [labelsy,constsy,typesy,varsy,initprocsy,proceduresy,functionsy,beginsy];
selectsys := [arrow,period,lbrack];
facbegsys := [intconst,realconst,stringconst,ident,lparent,lbrack,notsy];
statbegsys := [beginsy,gotosy,ifsy,whilesy,repeatsy,loopsy,forsy,withsy,casesy]
END (*INITSETS*) ;
INITPROCEDURE (*RESERVED WORDS*) ;
BEGIN
rw[ 1] := 'IF '; rw[ 2] := 'DO '; rw[ 3] := 'OF ';
rw[ 4] := 'TO '; rw[ 5] := 'IN '; rw[ 6] := 'OR ';
rw[ 7] := 'END '; rw[ 8] := 'FOR '; rw[ 9] := 'VAR ';
rw[10] := 'DIV '; rw[11] := 'MOD '; rw[12] := 'SET ';
rw[13] := 'AND '; rw[14] := 'NOT '; rw[15] := 'THEN ';
rw[16] := 'ELSE '; rw[17] := 'WITH '; rw[18] := 'GOTO ';
rw[19] := 'LOOP '; rw[20] := 'CASE '; rw[21] := 'TYPE ';
rw[22] := 'FILE '; rw[23] := 'EXIT '; rw[24] := 'BEGIN ';
rw[25] := 'UNTIL '; rw[26] := 'WHILE '; rw[27] := 'ARRAY ';
rw[28] := 'CONST '; rw[29] := 'LABEL '; rw[30] := 'EXTERN ';
rw[31] := 'RECORD '; rw[32] := 'DOWNTO '; rw[33] := 'PACKED ';
rw[34] := 'OTHERS '; rw[35] := 'REPEAT '; rw[36] := 'FORTRAN ';
rw[37] := 'FORWARD '; rw[38] := 'PROGRAM '; rw[39] := 'FUNCTION ';
rw[40] := 'PROCEDURE '; rw[41] := 'SEGMENTED '; rw[42] := 'INITPROCED';
frw[1] := 1; frw[2] := 1; frw[3] := 7; frw[4] := 15; frw[5] := 24;
frw[6] := 30; frw[7] := 36; frw[8] := 39; frw[9] := 40; frw[10] := 42;
frw[11] := 43
END (*RESERVED WORDS*) ;
INITPROCEDURE (*SYMBOLS*) ;
BEGIN
rsy[1]:=ifsy; rsy[2]:=dosy; rsy[3]:=ofsy;
rsy[4]:=tosy; rsy[8]:=forsy; rsy[12]:=setsy;
rsy[5]:=relop; rsy[6]:=addop; rsy[7]:=endsy;
rsy[9]:=varsy; rsy[10]:=mulop; rsy[11]:=mulop;
rsy[13]:=mulop; rsy[14]:=notsy; rsy[15]:=thensy;
rsy[16]:=elsesy; rsy[17]:=withsy; rsy[18]:=gotosy;
rsy[19]:=loopsy; rsy[20]:=casesy; rsy[21]:=typesy;
rsy[22]:=filesy; rsy[23]:=exitsy; rsy[24]:=beginsy;
rsy[25]:=untilsy; rsy[26]:=whilesy; rsy[27]:=arraysy;
rsy[28]:=constsy; rsy[29]:=labelsy; rsy[30]:=externsy;
rsy[31]:=recordsy; rsy[32]:=downtosy; rsy[33]:=packedsy;
rsy[34]:=otherssy; rsy[35]:=repeatsy; rsy[36]:=fortransy;
rsy[37]:=forwardsy; rsy[38]:=programsy; rsy[39]:=functionsy;
rsy[40]:=proceduresy; rsy[41]:=segmentsy; rsy[42]:=initprocsy;
ssy['A'] := othersy; ssy['B'] := othersy; ssy['C'] := othersy;
ssy['D'] := othersy; ssy['E'] := othersy; ssy['F'] := othersy;
ssy['G'] := othersy; ssy['H'] := othersy; ssy['I'] := othersy;
ssy['J'] := othersy; ssy['K'] := othersy; ssy['L'] := othersy;
ssy['M'] := othersy; ssy['N'] := othersy; ssy['O'] := othersy;
ssy['P'] := othersy; ssy['Q'] := othersy; ssy['R'] := othersy;
ssy['S'] := othersy; ssy['T'] := othersy; ssy['U'] := othersy;
ssy['V'] := othersy; ssy['W'] := othersy; ssy['X'] := othersy;
ssy['Y'] := othersy; ssy['Z'] := othersy; ssy['0'] := othersy;
ssy['1'] := othersy; ssy['2'] := othersy; ssy['3'] := othersy;
ssy['4'] := othersy; ssy['5'] := othersy; ssy['6'] := othersy;
ssy['7'] := othersy; ssy['8'] := othersy; ssy['9'] := othersy;
ssy['+'] := addop; ssy['-'] := addop; ssy['*'] := mulop;
ssy['/'] := mulop; ssy['('] := lparent; ssy[')'] := rparent;
ssy['$'] := othersy; ssy['='] := relop; ssy[' '] := othersy;
ssy[','] := comma; ssy['.'] := period; ssy[''''] := othersy;
ssy['['] := lbrack; ssy[']'] := rbrack; ssy[':'] := colon;
ssy['#'] := othersy; ssy['%'] := othersy; ssy['!'] := othersy;
ssy['&'] := othersy; ssy['↑'] := arrow; ssy['\'] := othersy;
ssy['<'] := relop; ssy['>'] := relop; ssy['@'] := othersy;
ssy['"'] := othersy; ssy['?'] := othersy; ssy[';'] := semicolon;
ssy['←'] := othersy;
END (*SYMBOLS*) ;
INITPROCEDURE (*OPERATORS*) ;
BEGIN
rop[ 1] := noop; rop[ 2] := noop; rop[ 3] := noop; rop[ 4] := noop;
rop[ 5] := inop; rop[ 6] := orop; rop[ 7] := noop; rop[ 8] := noop;
rop[ 9] := noop; rop[10] := idiv; rop[11] := imod; rop[12] := noop;
rop[13] :=andop; rop[14] := noop; rop[15] := noop; rop[16] := noop;
rop[17] := noop; rop[18] := noop; rop[19] := noop; rop[20] := noop;
rop[21] := noop; rop[22] := noop; rop[23] := noop; rop[24] := noop;
rop[25] := noop; rop[26] := noop; rop[27] := noop; rop[28] := noop;
rop[29] := noop; rop[30] := noop; rop[31] := noop; rop[32] := noop;
rop[33] := noop; rop[34] := noop; rop[35] := noop; rop[36] := noop;
rop[37] := noop; rop[38] := noop; rop[39] := noop; rop[40] := noop;
rop[41] := noop; rop[42] := noop;
sop['+'] := plus; sop['-'] := minus; sop['*'] := mul; sop['/'] := rdiv;
sop['='] := eqop; sop['#'] := noop; sop['!'] := noop; sop['&'] := noop;
sop['<'] := ltop; sop['>'] := gtop; sop['@'] := noop; sop['"'] := noop;
sop[' '] := noop; sop['$'] := noop; sop['%'] := noop; sop['('] := noop;
sop[')'] := noop; sop[','] := noop; sop['.'] := noop; sop['0'] := noop;
sop['1'] := noop; sop['2'] := noop; sop['3'] := noop; sop['4'] := noop;
sop['5'] := noop; sop['6'] := noop; sop['7'] := noop; sop['8'] := noop;
sop['9'] := noop; sop[':'] := noop; sop[';'] := noop; sop['?'] := noop;
sop['A'] := noop; sop['B'] := noop; sop['C'] := noop; sop['D'] := noop;
sop['E'] := noop; sop['F'] := noop; sop['G'] := noop; sop['H'] := noop;
sop['I'] := noop; sop['J'] := noop; sop['K'] := noop; sop['L'] := noop;
sop['M'] := noop; sop['N'] := noop; sop['O'] := noop; sop['P'] := noop;
sop['Q'] := noop; sop['R'] := noop; sop['S'] := noop; sop['T'] := noop;
sop['U'] := noop; sop['V'] := noop; sop['W'] := noop; sop['X'] := noop;
sop['Y'] := noop; sop['Z'] := noop; sop['['] := noop; sop['\'] := noop;
sop[']'] := noop; sop['↑'] := noop; sop['←'] := noop; sop[''''] := noop
END (*OPERATORS*) ;
INITPROCEDURE (*RECORD SIZES*);
BEGIN
debentry←size := 8;
idrecsize[types] := 5;
idrecsize[konst] := 6;
idrecsize[vars] := 6;
idrecsize[field] := 6;
idrecsize[proc] := 5;
idrecsize[func] := 5;
idrecsize[labels] := 5;
strecsize[scalar] := 2;
strecsize[subrange] := 4;
strecsize[pointer] := 2;
strecsize[power] := 2;
strecsize[arrays] := 3;
strecsize[records] := 3;
strecsize[files] := 2;
strecsize[tagfwithid] := 3;
strecsize[tagfwithoutid] := 2;
strecsize[variant] := 4
END (*RECORD SIZES*);
INITPROCEDURE (*ERROR MESSAGES*) ;
BEGIN
errmess15[ 1] := '":" EXPECTED ';
errmess15[ 2] := '")" EXPECTED ';
errmess15[ 3] := '"(" EXPECTED ';
errmess15[ 4] := '"[" EXPECTED ';
errmess15[ 5] := '"]" EXPECTED ';
errmess15[ 6] := '";" EXPECTED ';
errmess15[ 7] := '"=" EXPECTED ';
errmess15[ 8] := '"," EXPECTED ';
errmess15[ 9] := '":=" EXPECTED ';
errmess15[10] := '"OF" EXPECTED ';
errmess15[11] := '"DO" EXPECTED ';
errmess15[12] := '"IF" EXPECTED ';
errmess15[13] := '"END" EXPECTED ';
errmess15[14] := '"THEN" EXPECTED';
errmess15[15] := '"EXIT" EXPECTED';
errmess15[16] := 'ILLEGAL SYMBOL ';
errmess15[17] := 'NO SIGN ALLOWED';
errmess15[18] := 'NUMBER EXPECTED';
errmess15[19] := 'NOT IMPLEMENTED';
errmess15[20] := 'ERROR IN TYPE ';
errmess15[21] := 'COMPILER ERROR ';
errmess15[22] := 'DEVICE EXPECTED';
errmess15[23] := 'ERROR IN FACTOR';
errmess15[24] := 'TOO MANY DIGITS';
errmess20[ 1] := '"BEGIN" EXPECTED ';
errmess20[ 2] := '"UNTIL" EXPECTED ';
errmess20[ 3] := 'ERROR IN OPTIONS ';
errmess20[ 4] := 'CONSTANT TOO LARGE ';
errmess20[ 5] := 'DIGIT MUST FOLLOW ';
errmess20[ 6] := 'EXPONENT TOO LARGE ';
errmess20[ 7] := 'CONSTANT EXPECTED ';
errmess20[ 8] := 'SIMPLE TYPE EXPECTED';
errmess20[ 9] := 'IDENTIFIER EXPECTED ';
errmess20[10] := 'REALTYPE NOT ALLOWED';
errmess20[11] := 'MULTIDEFINED LABEL ';
errmess20[12] := 'FILENAME EXPECTED ';
errmess20[13] := 'SET TYPE EXPECTED ';
errmess20[14] := 'UNDEFINED LABEL ';
errmess20[15] := 'UNDECLARED LABEL ';
errmess25[ 1] := '"TO"/"DOWNTO" EXPECTED ';
errmess25[ 2] := '8 OR 9 IN OCTAL NUMBER ';
errmess25[ 3] := 'IDENTIFIER NOT DECLARED ';
errmess25[ 4] := 'FILE NOT ALLOWED HERE ';
errmess25[ 5] := 'INTEGER CONSTANT EXPECTED';
errmess25[ 6] := 'ERROR IN PARAMETERLIST ';
errmess25[ 7] := 'ALREADY FORWARD DECLARED ';
errmess25[ 8] := 'THIS FORMAT FOR REAL ONLY';
errmess25[ 9] := 'VARIANTTYPE MUST BE ARRAY';
errmess25[10] := 'TYPE CONFLICT OF OPERANDS';
errmess25[11] := 'MULTIDEFINED CASE LABEL ';
errmess25[12] := 'FOR INTEGER ONLY "O"/"H" ';
errmess25[13] := 'ARRAY INDEX OUT OF BOUNDS';
errmess25[14] := 'MISSING FILE DECLARATION ';
errmess25[15] := 'LABEL CONSTANT TOO GREAT ';
errmess25[16] := 'LABEL ALREADY DECLARED ';
errmess25[17] := 'END OF PROGRAM NOT FOUND ';
errmess25[18] := 'MORE THAN 72 SET ELEMENTS';
errmess30[ 1] := 'STRING CONSTANT IS TOO LONG ';
errmess30[ 2] := 'IDENTIFIER ALREADY DECLARED ';
errmess30[ 3] := 'SUBRANGE BOUNDS MUST BE SCALAR';
errmess30[ 4] := 'INCOMPATIBLE SUBRANGE TYPES ';
errmess30[ 5] := 'INCOMPATIBLE WITH TAGFIELDTYPE';
errmess30[ 6] := 'INDEX TYPE MAY NOT BE INTEGER ';
errmess30[ 7] := 'TYPE OF VARIABLE IS NOT ARRAY ';
errmess30[ 8] := 'TYPE OF VARIABLE IS NOT RECORD';
errmess30[ 9] := 'NO SUCH FIELD IN THIS RECORD ';
errmess30[10] := 'EXPRESSION TOO COMPLICATED ';
errmess30[11] := 'ILLEGAL TYPE OF OPERAND(S) ';
errmess30[12] := 'TESTS ON EQUALITY ALLOWED ONLY';
errmess30[13] := 'STRICT INCLUSION NOT ALLOWED ';
errmess30[14] := 'FILE COMPARISON NOT ALLOWED ';
errmess30[15] := 'ILLEGAL TYPE OF EXPRESSION ';
errmess30[16] := 'VALUE OF CASE LABEL TOO LARGE ';
errmess30[17] := 'TOO MANY NESTED WITHSTATEMENTS';
errmess30[18] := 'INVALID OR NO PROGRAM HEADING ';
errmess30[19] := 'TOO MANY LABEL DECLARATIONS ';
errmess30[20] := 'INCOMPATIBLE FORMALPARAMETER ';
errmess30[21] := 'STRING PACKAGE IS DISABLED '; (* 25.*)
errmess35[ 1] := 'STRING CONSTANT CONTAINS "<CR><LF>"';
errmess35[ 2] := 'LABEL NOT DECLARED ON THIS LEVEL ';
errmess35[ 3] := 'CALL NOT ALLOWED IN EXTERN PROGRAMS';
errmess35[ 4] := 'MORE THAN 12 FILES DECLARED BY USER';
errmess35[ 5] := 'FILE AS VALUE PARAMETER NOT ALLOWED';
errmess35[ 6] := 'TOO MUCH CODE: USE OPTION CODESIZE ';
errmess35[ 7] := 'NO PACKED STRUCTURE ALLOWED HERE ';
errmess35[ 8] := 'VARIANT MUST BELONG TO TAGFIELDTYPE';
errmess35[ 9] := 'TYPE OF OPERAND(S) MUST BE BOOLEAN ';
errmess35[10] := 'SET ELEMENT TYPES NOT COMPATIBLE ';
errmess35[11] := 'ASSIGNMENT TO FILES NOT ALLOWED ';
errmess35[12] := 'TOO MANY LABELS IN THIS PROCEDURE ';
errmess35[13] := 'INITPROCEDURE NOT ALLOWED HERE ';
errmess35[14] := 'CONTROL VARIABLE MAY NOT BE FORMAL ';
errmess35[15] := 'ILLEGAL TYPE OF FOR-CONTROLVARIABLE';
errmess35[16] := 'ONLY PACKED FILE OF CHAR ALLOWED ';
errmess35[17] := 'CONSTANT NOT IN BOUNDS OF SUBRANGE ';
errmess40[ 1] := 'IDENTIFIER IS NOT OF APPROPRIATE CLASS ';
errmess40[ 2] := 'TAGFIELD TYPE MUST BE SCALAR OR SUBRANGE';
errmess40[ 3] := 'INDEX TYPE MUST BE SCALAR OR SUBRANGE ';
errmess40[ 4] := 'TOO MANY NESTED SCOPES OF IDENTIFIERS ';
errmess40[ 5] := 'POINTER FORWARD REFERENCE UNSATISFIED ';
errmess40[ 6] := ' ';
errmess40[ 7] := 'TYPE OF VARIABLE MUST BE FILE OR POINTER';
errmess40[ 8] := 'MISSING CORRESPONDING VARIANTDECLARATION';
errmess40[ 9] := 'MORE THAN 6 VARIANTS IN CALL OF "NEW" ';
errmess40[10] := 'MORE THAN FOUR ERRORS IN THIS SOURCELINE';
errmess40[11] := 'NO INITIALISATION ON RECORDS OR FILES ';
errmess40[12] := 'PROGRAM TOO BIG FOR PASSGO. USE PASCAL ';
errmess40[13] := 'MORE THAN 100 INITPROCEDURES. USE PASCAL';
errmess45[ 1] := 'LOW BOUND MAY NOT BE GREATER THAN HIGH BOUND ';
errmess45[ 2] := 'IDENTIFIER OR "CASE" EXPECTED IN FIELDLIST ';
errmess45[ 3] := 'TOO MANY NESTED PROCEDURES AND/OR FUNCTIONS ';
errmess45[ 4] := 'FILE DECLARATION IN PROCEDURES NOT ALLOWED ';
errmess45[ 5] := 'MISSING RESULT TYPE IN FUNCTION DECLARATION ';
errmess45[ 6] := 'ASSIGNMENT TO FORMAL FUNCTION IS NOT ALLOWED ';
errmess45[ 7] := 'INDEX TYPE IS NOT COMPATIBLE WITH DECLARATION';
errmess45[ 8] := 'ERROR IN TYPE OF STANDARD PROCEDURE PARAMETER';
errmess45[ 9] := 'ERROR IN TYPE OF STANDARD FUNCTION PARAMETER ';
errmess45[10] := 'REAL AND STRING TAGFIELDS NOT IMPLEMENTED ';
errmess45[11] := 'SET ELEMENT TYPE MUST BE SCALAR OR SUBRANGE ';
errmess45[12] := 'ONLY ASSIGNMENTS ALLOWED IN INITPROCEDURES ';
errmess45[13] := 'NO CONSTANT OR EXPRESSION FOR VAR ARGUMENT ';
errmess45[14] := 'EXTERN DECLARATION NOT ALLOWED IN PROCEDURES ';
errmess45[15] := 'BODY OF FORWARD DECLARED PROCEDURE MISSING ';
errmess45[16] := 'DOUBLE FILE SPECIFICATION IN PROGRAM HEADING ';
errmess45[17] := 'TOO MUCH CODE FOR DEBUG: TRY MORE "CODESIZE" ';
errmess45[18] := 'NO FORMAL-PROC/FUNC IN FORTRAN-SUBROUTINE ';
errmess45[19] := 'THIS VAR ARGUMENT HAS TO BE OF TYPE STRING ';
errmess50[ 1] := 'TOO MANY FORWARD REFERENCES OF PROCEDURE ENTRIES ';
errmess50[ 2] := 'ASSIGNMENT TO STANDARD FUNCTION IS NOT ALLOWED ';
errmess50[ 3] := 'PARAMETER TYPE DOES NOT AGREE WITH DECLARATION ';
errmess50[ 4] := 'INITIALISATION ONLY BY ASSIGNMENT OF CONSTANTS ';
errmess50[ 5] := 'LABEL TYPE INCOMPATIBLE WITH SELECTING EXPRESSION ';
errmess50[ 6] := 'STATEMENT MUST END WITH ";","END","ELSE"OR"UNTIL" ';
errmess50[ 7] := 'NOT ALLOWED IN INITPROCEDURES (PACKED STRUCTURE?) ';
errmess50[ 8] := 'GOTO INTO MAIN PROGRAM NOT ALLOWED IF "EXTERN" ';
errmess50[ 9] := 'ASSIGNMENT TO FUNCTION NOT ALLOWED ON THIS LEVEL ';
errmess50[10] := 'NO STD- OR FORTRAN-PROC/FUNC AS ACTUAL-PROC/FUNC ';
errmess55[ 1] := 'FUNCTION RESULT TYPE MUST BE SCALAR,SUBRANGE OR POINTER';
errmess55[ 2] := 'REPETITION OF RESULT TYPE NOT ALLOWED IF FORW. DECL. ';
errmess55[ 3] := 'REPETITION OF PARAMETER LIST NOT ALLOWED IF FORW. DECL.';
errmess55[ 4] := 'NUMBER OF PARAMETERS DOES NOT AGREE WITH DECLARATION ';
errmess55[ 5] := 'RESULT TYPE OF PARAMETER-FUNC DOES NOT AGREE WITH DECL.';
errmess55[ 6] := 'SELECTED EXPRESSION MUST HAVE TYPE OF CONTROL VARIABLE ';
errmess55[ 7] := 'TOO MANY FILES OR TOO BIG FILE ELEMENTS. USE PASCAL. ';
errmess55[ 8] := 'ALREADY DECLARED. PREVIOUS DECLARATION WAS NOT FORWARD ';
END (*ERROR MESSAGES*) ;
INITPROCEDURE (*PCROSS OPTION NAMES*) ;
(* 4. TO BE ABLE TO PASS THEM TO PCROSS *)
BEGIN
pcross←option←name [1] := 'NEW ';
pcross←option←name [2] := 'NONEW ';
pcross←option←name [3] := 'CROSS ';
pcross←option←name [4] := 'NOCROSS ';
pcross←option←name [5] := 'WIDTH ';
pcross←option←name [6] := 'INDENT ';
pcross←option←name [7] := 'INCREMENT ';
pcross←option←name [8] := 'DOTS ';
pcross←option←name [9] := 'NODOTS ';
pcross←option←name [10] := 'BEGIN ';
pcross←option←name [11] := 'FORCE ';
pcross←option←name [12] := 'NOFORCE ';
pcross←option←name [13] := 'CLEAN ';
pcross←option←name [14] := 'NOCLEAN ';
pcross←option←name [15] := 'RES ';
pcross←option←name [16] := 'NONRES ';
pcross←option←name [17] := 'COMM ';
pcross←option←name [18] := 'STR ';
pcross←option←name [19] := 'CASE ';
END (*PCROSS OPTION NAMES*) ;
(*----------------------------------------------------------------------------*)
(* AUXILIAR PROCEDURES FOR INITIALIZATION, ERROR REPORT *)
PROCEDURE init←compile;
BEGIN (* INIT←COMPILE *)
program←count := program←count + 1;
programname := ' ';
forward←pointer←type := NIL; (* 13. LASTBTP REPEATED BELOW.*)
fglobptr := NIL; fileptr := sfileptr;
localpfptr := NIL; declscalptr := sdeclscalptr;
globtestp := NIL; last←label := NIL;
errmptr := NIL; parmptr := NIL;
backwparmptr := NIL; externpfptr := sexternpfptr;
lastbtp := slastbtp; sstringlength := NIL; (* 25.*)
loadnoptr := true; initglobals := false;
followerror := false; errorinline := false;
dp := true; search←error := true;
error←flag := false; overrun := false;
error←exit := false; ttyread := false;
entry←done := false; first←symbol := true;
reset←possible := true; incondcomp := false;
outputwrite := false; inputpar := false; (* 13.*)
outputpar := false; (* 13.*) parsingparameters := false; (* 25.*)
sstringstart := false; (* 25.*)
ic := high←start; lc := low←start;
library←index := 0; errinx := 0;
errorcount := 0; entries := 0;
debugentry.standardidtree := 0; debugentry.globalidtree := 0;
jumper := 0; jump←address := 0;
aos := b0;
FOR i := 1 TO 18 DO arraybps[i].state := unused;
arraybps[7].state := requested;
FOR i := 1 TO stdchcntmax DO errline[i] := ' ';
FOR support←index := first(support←index) TO last(support←index) DO
runtime←support.link[support←index] := 0;
relocation←block.count := 0;
top := 1; level := 1;
WITH display[1] DO
BEGIN
fname := NIL; occur := blck
END;
WHILE externpfptr <> NIL DO
WITH externpfptr↑ DO
BEGIN
linkchain[0] := 0; externpfptr := pfchain
END;
externpfptr := sexternpfptr;
WHILE declscalptr <> NIL DO
WITH declscalptr↑ DO
BEGIN
vectoraddr := 0; vectorchain := 0;
request := false; declscalptr := nextscalar
END;
declscalptr := sdeclscalptr;
WHILE lastbtp <> NIL DO
WITH lastbtp↑ DO
BEGIN
arraysp↑.arraybpaddr := 0; lastbtp := last
END;
lastbtp := slastbtp
END (* INIT←COMPILE *);
PROCEDURE error(ferrnr: integer);
VAR
lpos,larw : integer;
BEGIN (*ERROR*)
IF NOT followerror THEN
BEGIN
errorcount := errorcount + 1; (* 13. KEEP THE ERRORS COUNTED RIGHT.*)
error←flag := true ;
IF errinx >= maxerr THEN
BEGIN
errlist[maxerr].nmr := 410; errinx := maxerr
END
ELSE
BEGIN
errinx := errinx + 1;
WITH errlist[errinx] DO
BEGIN
nmr := ferrnr; tic := '↑'
END
END;
followerror := true; errorinline := true;
IF (ferrnr <> 214) AND (ferrnr <> 356) AND (ferrnr <> 405) AND
(ferrnr <> 465) AND (ferrnr <> 467) AND (ferrnr <> 264) AND
(ferrnr <> 267) THEN
IF eoln(source) THEN
errline [chcnt] := '↑'
ELSE
errline [chcnt-1] := '↑'
ELSE
errlist[errinx].tic := ' ';
IF errinx > 1 THEN
WITH errlist [ errinx-1] DO
BEGIN
lpos := pos; larw := arw
END;
WITH errlist [errinx] DO
BEGIN
pos := chcnt;
IF errinx = 1 THEN
arw := 1
ELSE
IF lpos = chcnt THEN
arw := larw
ELSE
arw := larw + 1
END
END
END (*ERROR*) ;
PROCEDURE enterid(fcp: ctp);
(*ENTER ID POINTED TO BY FCP INTO THE NAME-TABLE,
WHICH ON EACH DECLARATION LEVEL IS ORGANISED AS
AN UNBALANCED BINARY TREE*)
VAR
new←name: alfa; lcp, lcp1: ctp; lleft: boolean;
BEGIN (*ENTERID*)
lcp := display[top].fname;
IF lcp = NIL THEN
display[top].fname := fcp
ELSE
BEGIN
new←name := fcp↑.name;
REPEAT
lcp1 := lcp;
IF lcp↑.name <= new←name THEN
BEGIN
IF lcp↑.name = new←name THEN
(*NAME CONFLICT*)
IF new←name[1] IN digits THEN
error(266) (*MULTI-DECLARED LABEL*)
ELSE
error(302) (*MULTI-DECLARED IDENTIFIER*) ;
lcp := lcp↑.rlink; lleft := false
END
ELSE
BEGIN
lcp := lcp↑.llink; lleft := true
END
UNTIL lcp = NIL;
IF lleft THEN
lcp1↑.llink := fcp
ELSE
lcp1↑.rlink := fcp
END;
WITH fcp↑ DO
BEGIN
llink := NIL; rlink := NIL; selfctp := NIL
END
END (*ENTERID*) ;
PROCEDURE enterstdtypes;
VAR
llcp, lcp: ctp;
PROCEDURE enterstdstring(VAR stringptr: stp; lowbnd, highbnd: integer);
VAR
lbtp: btp; lsp: stp;
BEGIN (*ENTERSTDSTRING*)
new(lsp,subrange);
WITH lsp↑ DO
BEGIN
rangetype := intptr; vmin.ival := lowbnd; vmax.ival := highbnd;
selfstp := NIL; size := 1; bitsize := bitmax
END;
new(stringptr,arrays);
WITH stringptr↑ DO
BEGIN
arraypf := true; arraybpaddr := 0; selfstp := NIL;
aeltype := asciiptr; inxtype := lsp; size := (highbnd-lowbnd+5) DIV 5;
bitsize := bitmax
END;
new(lbtp);
WITH lbtp↑ DO
BEGIN
last := lastbtp; arraysp := stringptr;
bitsize := 7; lastbtp := lbtp
END;
WITH arraybps[7], abyte DO
BEGIN
sbits := 7; pbits := bitmax; dummybit := 0;
ibit := 0; ireg := reg1; reladdr := 0;
bytemax := 6; state := requested
END
END;
BEGIN (*ENTERSTDTYPES*)
new(intptr,scalar,standard); (*INTEGER*)
WITH intptr↑ DO
BEGIN
size := 1;bitsize := bitmax; selfstp := NIL
END;
new(realptr,scalar,standard); (*REAL*)
WITH realptr↑ DO
BEGIN
size := 1;bitsize := bitmax; selfstp := NIL
END;
new(asciiptr,scalar,standard); (*ASCII*)
WITH asciiptr↑ DO
BEGIN
size := 1;bitsize := 7; selfstp := NIL
END;
new(boolptr,scalar,declared); (*BOOLEAN*)
WITH boolptr↑ DO
BEGIN
size := 1;bitsize := 1; selfstp := NIL
END;
new(nilptr,pointer); (*NIL*)
WITH nilptr↑ DO
BEGIN
eltype := NIL; size := 1; bitsize := 18; selfstp := NIL
END;
new(anyfileptr,files); (*"ANY FILE"*)
WITH anyfileptr↑ DO
BEGIN
filtype := NIL; size := 0; bitsize := 0; selfstp := NIL
END;
new(charptr,subrange); (*CHAR*)
WITH charptr↑ DO
BEGIN
size := 1; bitsize := 7; selfstp := NIL;
rangetype := asciiptr; vmin.ival := ord(' ');
vmax.ival := ord('←')
END;
new(textptr,files); (*TEXT*)
WITH textptr↑ DO
BEGIN
filtype := charptr; size := 1+sizeoffileblock; bitsize := bitmax;
file←mode := ascii←mode; filepf := true; selfstp := NIL;
file←form := text←file;
END;
enterstdstring(alfaptr,1,alfalength);
enterstdstring(packc9ptr,1,9);
enterstdstring(packc8ptr,1,8);
enterstdstring(packc6ptr,1,6);
enterstdstring(packc5ptr,1,5);
enterstdstring(packc3ptr,1,3);
slastbtp := lastbtp;
(* 25. STANDARD TYPES NEEDED FOR THE STRING PACKAGE.*)
IF stringpack THEN
BEGIN
enterstdstring(packc135ptr,1,135);
enterstdstring(packc1ptr,1,1);
enterstdstring(packc0ptr,1,0);
new(strgrngptr, subrange); (* STRGRANGE *)
WITH strgrngptr↑ DO
BEGIN
size := 1; bitsize := bitmax; selfstp := NIL;
rangetype := intptr; vmin.ival := 1; vmax.ival := strglgth;
END;
new(strgrng0ptr, subrange); (* STRGRANGE0 *)
WITH strgrng0ptr↑ DO
BEGIN
size := 1; bitsize := bitmax; selfstp := NIL;
rangetype := intptr; vmin.ival := 0; vmax.ival := strglgth;
END;
new(lcp,field); (* STRING.STRTEXT *)
WITH lcp↑ DO
BEGIN
name := 'STRTEXT '; idtype := packc135ptr;
packf := notpack; fldaddr := 0;
END;
enterid(lcp);
llcp := lcp;
new(lcp, field); (* STRING.LEN *)
WITH lcp↑ DO
BEGIN
name := 'LEN '; idtype := strgrngptr0; next := NIL;
packf := notpack; fldaddr := packc135ptr↑.size;
END;
llcp↑.next := lcp;
enterid(lcp);
new(sstringptr, records); (* STRING *)
WITH sstringptr↑ DO
BEGIN
selfstp := NIL; size := packc135ptr↑.size + 1; bitsize := bitmax;
recordpf := false; fstfld := llcp; recvar := packc135ptr;
END;
END;
END (*ENTERSTDTYPES*) ;
PROCEDURE enterstdnames;
VAR
cp: ctp;
i,j: integer;
lfileptr: ftp;
lcsp: csp;
PROCEDURE enterstdprocfunc(findex: integer; fidclass: idclass; fidtype: stp; fnext: ctp);
VAR
i: integer; lcp: ctp; nameix: namekind;
BEGIN (*ENTERSTDPROCFUNC*)
IF fidclass = func THEN
BEGIN
nameix := declfunc; new(lcp,func,declared,actual)
END
ELSE
BEGIN
nameix := declproc; new(lcp,proc,declared,actual)
END;
WITH lcp↑ DO
BEGIN
idtype := fidtype; next := fnext; forwdecl := false; highest←register := stdparregcmax;
pflev := 0; pfaddr := 0; pfchain := externpfptr; externpfptr := lcp; externdecl := true;
FOR i := 0 TO maxlevel DO linkchain[i] := 0;
language := extlanguage[nameix,findex];
externalname := extna[nameix,findex]; name := na[nameix,findex];
END;
enterid(lcp)
END (*ENTERSTDPROCFUNC*);
PROCEDURE enterstdparameter(fidtype: stp; fidkind: idkind; fnext: ctp; faddr: integer);
BEGIN (*ENTERSTDPARAMETER*)
new(cp,vars);
WITH cp↑ DO
BEGIN
name := ' '; idtype := fidtype;
vkind := fidkind; next := fnext; vlev := 1; vaddr := faddr
END
END (*ENTERSTDPARAMETER*);
PROCEDURE enterstdid(fidclass: idclass; fname: alfa; fidtype: stp; fnext: ctp; fival: integer);
BEGIN (*ENTERSTDID*)
new(cp);
WITH cp↑ DO
BEGIN
klass := fidclass; name := fname; idtype := fidtype; next := fnext;
IF fidclass = konst THEN
values.ival := fival
END;
enterid(cp)
END (*ENTERSTDID*);
BEGIN (*ENTERSTDNAMES*)
enterstdid(types,'INTEGER ',intptr,NIL,0);
enterstdid(types,'REAL ',realptr,NIL,0);
enterstdid(types,'CHAR ',charptr,NIL,0);
enterstdid(types,'ASCII ',asciiptr,NIL,0);
enterstdid(types,'BOOLEAN ',boolptr,NIL,0);
enterstdid(types,'TEXT ',textptr,NIL,0);
enterstdid(types,'ALFA ',alfaptr,NIL,0);
enterstdid(konst,'NIL ',nilptr,NIL,377777B);
enterstdid(konst,'ALFALENGTH',intptr,NIL,10);
enterstdid(konst,'MAXINT ',intptr,NIL,377777777777B);
enterstdid(konst,'MININT ',intptr,NIL,-maxint - 1);
new(lcsp,reel); lcsp↑.intval := 377777777777B;
enterstdid(konst,'MAXREAL ',realptr,NIL,ord(lcsp));
new(lcsp,reel); lcsp↑.intval := 400000000B;
enterstdid(konst,'SMALLREAL ',realptr,NIL,ord(lcsp));
cp := NIL;
FOR i := 1 TO 2 DO
enterstdid(konst,na[stdconst,i],boolptr,cp,i-1);
WITH boolptr↑ DO
BEGIN
fconst := cp; vectoraddr := 0; vectorchain := 0;
tlev := 0; request := false; nextscalar := NIL;
dimension := 1
END;
declscalptr := boolptr;
cp := NIL;
FOR i := 3 TO 35 DO
enterstdid(konst,na[stdconst,i],asciiptr,cp,i-3);
enterstdid(konst,na[stdconst,36],asciiptr,cp,177B);
(* 25. STRING,STRGRANGE,STRGRANGE0,MAXSTRLEN,NULLSTR: FOR THE STRING PACKAGE.*)
IF stringpack THEN
BEGIN
enterstdid(types,'STRING ', sstringptr, NIL, 0);
enterstdid(types,'STRGRANGE ', strgrngptr, NIL, 0);
enterstdid(types,'STRGRANGE0', strgrngptr0, NIL, 0);
enterstdid(konst,'MAXSTRLEN ', strgrngptr, NIL, 135);
new(lcsp,strg:140);
enterstdid(konst,'NULLSTR ', packc0ptr, NIL, ord(lcsp));
END;
(*INPUT,OUTPUT,TTY,TTYOUTPUT*)
FOR i := 1 TO namax[stdfile] DO
BEGIN
new(cp,vars);
stdfileptr[i] := cp;
WITH cp↑ DO
BEGIN
name := na[stdfile,i]; idtype := textptr; channel := i-1;
vkind := actual; next := NIL; vlev := 0;
vaddr:= lc;
lc:=lc+idtype↑.size;
new(lfileptr) ;
WITH lfileptr↑ DO
BEGIN
nextftp := fileptr ;
fileident := cp
END ;
fileptr := lfileptr
END;
enterid(cp)
END;
(* GET,GETLN,PUT,PUTLN,RESET,REWRITE,READ,READLN,
WRITE,WRITELN,PACK,UNPACK,NEW,GETLINR,
PAGE,PROTECTION,RUN,DATE,TIME,DISPOSE,
HALT,GETSEG,PUTSEG,MESSAGE,LINELIMIT*)
FOR i := 1 TO namax[stdproc] DO
BEGIN
new(cp,proc,standard);
WITH cp↑ DO
BEGIN
name := na[stdproc,i]; idtype := NIL;
next := NIL; key := i
END;
enterid(cp)
END;
(* CLOCK,ABS,SQR,ODD,ORD,CHR,PRED,SUCC,EOF,EOLN,REALTIME,CARD,
LOWERBOUND,UPPERBOUND,MIN,MAX,FIRST,LAST,EOS*)
FOR i := 1 TO namax[stdfunc] DO
BEGIN
new(cp,func,standard);
WITH cp↑ DO
BEGIN
name := na[stdfunc,i]; idtype := NIL;
next := NIL; key := i
END;
enterid(cp)
END;
(* COS,EXP,SQRT,ALOG,ATAN,ALOG10,
SIND,COSD,SINH,COSH,TANH,ASIN,ACOS,RAN,SIN*)
enterstdparameter(realptr,actual,NIL,2);
FOR i := 1 TO 15 DO enterstdprocfunc(i,func,realptr,cp);
(* ROUND, EXPO *)
enterstdprocfunc(16,func,intptr,cp);
enterstdprocfunc(17,func,intptr,cp);
(* OPTION *)
enterstdparameter(alfaptr,actual,NIL,2);
enterstdprocfunc(18,func,boolptr,cp);
(* TRUNC *)
enterstdparameter(realptr,actual,NIL,2);
enterstdprocfunc(20,func,intptr,cp);
(* GETFILENAME *)
enterstdparameter(alfaptr,actual,NIL,6);
enterstdparameter(packc6ptr,formal,cp,5);
enterstdparameter(intptr,formal,cp,4);
enterstdparameter(intptr,formal,cp,3);
enterstdparameter(packc9ptr,formal,cp,2);
enterstdparameter(anyfileptr,formal,cp,1);
enterstdprocfunc(1,proc,NIL,cp);
(* GETOPTION *)
enterstdparameter(intptr,formal,NIL,4);
enterstdparameter(alfaptr,actual,cp,2);
enterstdprocfunc(2,proc,NIL,cp);
(* GETSTATUS *)
enterstdparameter(packc6ptr,formal,NIL,5);
enterstdparameter(intptr,formal,cp,4);
enterstdparameter(intptr,formal,cp,3);
enterstdparameter(packc9ptr,formal,cp,2);
enterstdparameter(anyfileptr,formal,cp,1);
enterstdprocfunc(3,proc,NIL,cp);
(* 7. KNOW ABOUT NEW RUNTIMES IN CCL SCANNER.*)
(*ASKFILENAME*)
enterstdparameter (boolptr, formal, NIL, 10);
enterstdparameter (boolptr, actual, cp, 9);
enterstdparameter (alfaptr, actual, cp, 7);
enterstdparameter (alfaptr, actual, cp, 5);
enterstdparameter (packc6ptr, formal, cp, 4);
enterstdparameter (intptr, formal, cp, 3);
enterstdparameter (intptr, formal, cp, 2);
enterstdparameter (packc9ptr, formal, cp, 1);
enterstdprocfunc (4, proc, NIL, cp);
(*STARTFILE*)
enterstdparameter (packc3ptr, actual, NIL, 9);
enterstdparameter (alfaptr, actual, cp, 7);
enterstdparameter (boolptr, actual, cp, 6);
enterstdparameter (packc6ptr, formal, cp, 5);
enterstdparameter (intptr, formal, cp, 4);
enterstdparameter (intptr, formal, cp, 3);
enterstdparameter (packc9ptr, formal, cp, 2);
enterstdparameter (anyfileptr, formal, cp, 1);
enterstdprocfunc (5,proc, NIL, cp);
(*GETPARAMETER*)
enterstdparameter (boolptr, actual, NIL, 4);
enterstdparameter (alfaptr, formal, cp, 3);
enterstdparameter (alfaptr, formal, cp, 2);
enterstdparameter (anyfileptr, formal, cp, 1);
enterstdprocfunc (6, proc, NIL, cp);
(*GETNEXTCALL*)
enterstdparameter (packc6ptr, formal, NIL, 2);
enterstdparameter (packc9ptr, formal, cp, 1);
enterstdprocfunc (7, proc, NIL, cp);
(*FILNAM*)
enterstdparameter (boolptr, formal, NIL, 9);
enterstdparameter (boolptr, formal, cp, 8);
enterstdparameter (boolptr, actual, cp, 7);
enterstdparameter (alfaptr, actual, cp, 5);
enterstdparameter (packc6ptr, formal, cp, 4);
enterstdparameter (intptr, formal, cp, 3);
enterstdparameter (packc9ptr, formal, cp, 2);
enterstdparameter (anyfileptr, formal, cp, 1);
enterstdprocfunc (8, proc, NIL, cp);
(*REENTER, SETTIME*)
enterstdprocfunc (9, proc, NIL, NIL);
enterstdprocfunc (10, proc, NIL, NIL);
(*TIMEREPORT*)
enterstdparameter (alfaptr, actual, NIL, 2);
enterstdparameter (anyfileptr, formal, cp, 1);
enterstdprocfunc (11, proc, NIL, cp);
(*RUNTIME*)
enterstdparameter (alfaptr, formal, NIL, 1);
enterstdprocfunc (12, proc, NIL, cp);
(*ELAPSEDTIME*)
enterstdparameter (alfaptr, formal, NIL, 1);
enterstdprocfunc (13, proc, NIL, cp);
(* 25. FOR THE STRING PACKAGE: *)
IF stringpack THEN
BEGIN
(* LENGTH *)
enterstdparameter(sstringptr,actual,NIL,2);
enterstdprocfunc(21,func,strgrngptr,cp);
(* GETCHAR *)
enterstdparameter(strgrngptr,actual,NIL,30);
enterstdparameter(sstringptr,actual,cp,2);
enterstdprocfunc(22,func,charptr,cp);
(* POS *)
enterstdparameter(sstringptr,actual,NIL,30);
enterstdparameter(sstringptr,actual,cp,2);
enterstdprocfunc(23,func,intptr,cp);
(* STRLT, STRLE, STREQ, STRGE, STRGT, STRNE *)
FOR i := 24 TO 29 DO
BEGIN
enterstdparameter(sstringptr,actual, NIL,30);
enterstdparameter(sstringptr,actual,cp,2);
enterstdprocfunc(i,func,boolptr,cp);
END;
(* PUTCHAR *)
enterstdparameter(strgrngptr,actual,NIL,3);
enterstdparameter(sstringptr,formal,cp,2);
enterstdparameter(charptr,actual,cp,1);
enterstdprocfunc(14,proc,NIL,cp);
(* ASSIGN *)
enterstdparameter(sstringptr,formal,NIL,29);
enterstdparameter(sstringptr,actual,cp,1);
enterstdprocfunc(15,proc,NIL,cp);
(* SUBSTR *)
enterstdparameter(intptr,actual,NIL,32);
enterstdparameter(intptr,actual,cp,31);
enterstdparameter(intptr,actual,cp,30);
enterstdparameter(sstringptr,formal,cp,29);
enterstdparameter(sstringptr,actual,cp,1);
enterstdprocfunc(16,proc,NIL,cp);
(* CONCAT *)
enterstdparameter(sstringptr,formal,NIL,29);
enterstdparameter(sstringptr,actual,cp,1);
enterstdprocfunc(17,proc,NIL,cp);
END;
sexternpfptr := externpfptr;
sfileptr := fileptr;
sdeclscalptr := declscalptr;
lcmain := lc
END (*ENTERSTDNAMES*) ;
PROCEDURE enterundecl;
VAR
i: integer;
BEGIN (*ENTERUNDECL*)
new(utypptr,types);
WITH utypptr↑ DO
BEGIN
name := ' '; idtype := NIL; next := NIL
END;
new(ucstptr,konst);
WITH ucstptr↑ DO
BEGIN
name := ' '; idtype := NIL; next := NIL;
values.ival := 0
END;
new(uvarptr,vars);
WITH uvarptr↑ DO
BEGIN
name := ' '; idtype := NIL; vkind := actual;
next := NIL; vlev := 0; vaddr := 0
END;
new(ufldptr,field);
WITH ufldptr↑ DO
BEGIN
name := ' '; idtype := NIL; next := NIL; fldaddr := 0;
packf := notpack
END;
new(uprcptr,proc,declared,actual);
WITH uprcptr↑ DO
BEGIN
name := ' '; idtype := NIL; forwdecl := false;
FOR i := 0 TO maxlevel DO linkchain[i] := 0;
next := NIL; externdecl := false; pflev := 0; pfaddr := 0
END;
new(ufctptr,func,declared,actual);
WITH ufctptr↑ DO
BEGIN
name := ' '; idtype := NIL; next := NIL;
FOR i := 0 TO maxlevel DO linkchain[i] := 0;
forwdecl := false; externdecl := false; pflev := 0; pfaddr := 0
END
END (*ENTERUNDECL*) ;
(* the next procedure declarations are needed whenever this compiler is bootstrapped
* from a less general pascal compiler. *)
PROCEDURE runtime (VAR buffer: alfa);
extern;
PROCEDURE elapsedtime (VAR buffer: alfa);
extern;
PROCEDURE settime;
extern;
PROCEDURE getnextcall (VAR filename: pack9;
VAR device: pack6);
extern;
PROCEDURE askfilename(VAR filename: pack9;
VAR protection,ufd: integer;
VAR device: pack6;
fileident,progname: alfa;
inputfile: boolean;
VAR fromtmpfile: boolean);
extern;
PROCEDURE startfile(VAR currentfile: anyfile;
VAR filename: pack9;
VAR protection,ufd: integer;
VAR device: pack6;
inputfile: boolean;
fileident: alfa;
defaultext: pack3);
extern;
PROCEDURE getparameter(VAR currentfile: anyfile;
VAR fileident,programname:alfa;
inputfile:boolean);
extern;
(* end of the bootstrapping procedure declarations *)
PROCEDURE get←directives;
(****************************************************************************************
*
* DECSYSTEM-10 CONCISE COMMAND LANGUAGE INTERFACE
*
* DEFINITIONS:
*
* <FILE SPECIFICATION> ::= <EMPTY> OR <FILENAME> OR
* <DEVICE>:<FILENAME>.<EXTENSION>[<PROJECT>,<PROGRAMMER>]<<PROTECTION>>
* (<SWITCH>,...,<SWITCH>)
* /<SWITCH>.../<SWITCH>
*
* <PROGRAMNAME>, <DEVICE>, <FILENAME>, <EXTENSION> ::= <IDENTIFIER>
* <PROJECT>, <PROGRAMMER>, <PROTECTION> ::= <UNSIGNED OCTAL NUMBER>
* <SWITCH> ::= <IDENTIFIER> OR <IDENTIFIER>:<VALUE>
* <VALUE> ::= <DECIMAL NUMBER> OR <LETTER> OR <ILLEGAL SYMBOL>
*
****************************************************************************************)
(* 23. USE THE PROCEDURES FROM THE LIBRARY, TO GUARANTEE CONSISTENCY OF FUTURE CHANGES.*)
VAR
object←protection , object←ufd,
source←protection , source←ufd ,
list←protection , list←ufd : integer ;
object←device,
source←device , list←device : PACKED ARRAY [1..6] OF char ;
fromtmpfile: boolean;
BEGIN (*GET←DIRECTIVES*)
(* suppressed to allow for bootstrapping
askfilename(object←file,object←protection,object←ufd,object←device, (* GET THE FILE NAMES.
'OBJECT ','PASCAL ',false,fromtmpfile);
*)
askfilename(list←file,list←protection,list←ufd,list←device,
'LIST ','PASCAL ',false,fromtmpfile);
askfilename(source←file,source←protection,source←ufd,source←device,
'SOURCE ','PASCAL ',true,fromtmpfile);
IF (source←file[1] = ' ') AND (source←device = 'DSK ') THEN
(* OPEN SOURCE FILE.*)
source←file := 'SOURCE ';
startfile (source, source←file, source←protection, source←ufd,
source←device, true, 'SOURCE ', 'PAS');
(* bootstrapping
IF (object←file [1] = ' ') AND (object←device = 'DSK ') THEN
(* OPEN OBJECT FILE.
IF source←file = 'SOURCE ' THEN
object←file := 'OBJECT '
ELSE
FOR i := 1 TO 6 DO
object←file[i] := source←file[i];
startfile(object,object←file,object←protection,object←ufd,
object←device,false,'OBJECT ','REL');
*)
cross←reference := option('CREF ') OR option('C ') ; (* OPEN LIST FILE, IF REQUESTED.*)
list←code := option('CODE ');
lptfile := NOT option('NOLIST ') AND ( list←code OR
option('LPT ') OR
(option('LIST ') AND NOT cross←reference) OR
(list←file <> ' ') OR
(list←device <> 'DSK ')); (* 9.*)
(* 11. DEFAULT THE LIST FILE NAME IF NEEDED.*)
IF lptfile THEN
BEGIN
IF (list←file [1] = ' ') AND (list←device = 'DSK ') THEN
FOR i := 1 TO 6 DO
list←file[i] := source←file[i];
startfile(list,list←file,list←protection,list←ufd,list←device,
false,'LIST ','LST');
END;
debug := option('DEBUG ') OR option ('D '); (* 13.*) (* CHECK SWITCHES.*)
debug←switch := debug;
runtime←check := NOT option('NOCHECK ');
resettty := NOT option ('NOTTY ');
IF option('CODESIZE ') THEN
getoption('CODESIZE ',code←size);
IF option('REGISTER ') THEN
BEGIN
getoption('REGISTER ',i);
IF i IN [regin..within] THEN
parregcmax := i
END;
(* 8. ALLOW FOR SWITCH /VERSION.*)
IF option ('VERSION ') THEN
getoption ('VERSION ',goodversion);
fortran←enviroment := option('FORTIO ');
external := option('EXTERN ');
IF option('RUNCORE ') THEN
getoption('RUNCORE ',runcore);
IF option('CARD ') THEN
chcntmax := 72;
IF option('FILE ') THEN
BEGIN
getoption('FILE ',i);
IF i IN [1..max←file] THEN
start←channel := i + namax[stdfile] - 2
END;
(* 1. IF A LINKER NAME CAME IN THE TEMPCORE FILE, LOAD←AND←GO.*)
IF fromtmpfile THEN
(* ONLY IF A TMPCORE FILE WAS SUPPLIED.*)
BEGIN
getnextcall(linker←file,link←device);
IF linker←file = 'LOADER ' THEN
BEGIN
load←and←go := true;
link←tmpfile := 'LOA TMP';
END
ELSE
BEGIN
IF (linker←file = 'LINK ') OR (linker←file = 'LINK10 ') THEN
BEGIN
load←and←go := true;
link←tmpfile := 'LNK TMP';
END
ELSE
(* NO LEGAL LINKER NAME.*)
link←tmpfile := ' ';
END;
END;
load←and←go := load←and←go OR (option ('LINK ') OR
option ('EXECUTE ') OR option ('LOAD '))
AND NOT external;
reset(tempcore,link←tmpfile); (* CHECK FOR THE DEBUG SWITCH IN THE TEMPFILE FOR THE LINKER *)
IF NOT eof(tempcore) THEN
BEGIN
new(command←buffer:buffer←size);
command←buffer↑[0] := ' '; i := 1;
WHILE NOT eof(tempcore) AND (i < buffer←size) DO
BEGIN
IF eoln(tempcore) THEN
BEGIN
readln(tempcore);
command←buffer↑[i] := cr;
command←buffer↑[i+1] := lf; i := i + 2
END
ELSE
(* NOT EOLN(TEMPCORE) *)
BEGIN
read(tempcore,ch);
command←buffer↑[i] := ch;
IF (command←buffer↑[i-1] = '/') AND (ch = 'D') THEN
BEGIN
debug := true; debug←switch := true;
(* 13. GET RID OF THE REST OF THE STANDARD SWITCH, /DEBUG:PASCAL*)
WHILE ch IN ['A'..'Z',':'] DO
read (tempcore, ch);
command←buffer↑[i-1] := ch;
END
ELSE
i := i + 1
END
END;
rewrite(tempcore,link←tmpfile);
write(tempcore,command←buffer↑:i);
dispose(command←buffer:buffer←size)
END
ELSE
(* EOF(TEMPCORE) *)
BEGIN
IF load←and←go THEN
BEGIN
rewrite(tempcore,link←tmpfile); (* 1. FLEXIBLE NAME OF LINKER.*)
write(tempcore,'DSK:',object←file:6);
IF option('EXECUTE ') THEN
write(tempcore,' /E');
write(tempcore,'/G'); (* 1. MORE CORRECT ORDERING.*)
END
END;
END (*GET←DIRECTIVES*);
(* COMPILE[ AUXILIAR PROCEDURES. *)
PROCEDURE compile;
LABEL
111;
VAR
escape: boolean;
PROCEDURE newpager;
BEGIN (*NEWPAGER*)
WITH pager, word1 DO
BEGIN
ac := pagecnt DIV 16;
inxreg := pagecnt MOD 16; address := lastpager;
lhalf := lastline; rhalf := laststop;
lastline := -1
END
END (*NEWPAGER*);
PROCEDURE writebuffer;
BEGIN (*WRITEBUFFER*)
IF list←code THEN
BEGIN
writeln(list,buffer:chcnt);
FOR chcnt := 1 TO 17 DO buffer[chcnt] := ' ';
chcnt := 17
END
END (*WRITEBUFFER*);
PROCEDURE getnextline;
BEGIN (*GETNEXTLINE*)
LOOP
getlinenr(source,linenr)
EXIT IF (linenr <> ' ') OR eof(source);
IF debug AND (lastline > -1) THEN
newpager;
pagecnt := pagecnt + 1;
IF lptfile THEN
BEGIN
page(list); writeln(list,'PAGE ',pagecnt:3); writeln(list)
END;
(* 6. GIVE PAGENUMBERS ON TTY.*)
IF programname <> ' ' THEN
write (tty, pagecnt:3, '..');
break (tty);
error←in←heading := true;
readln(source) (*TO OVERREAD SECOND <LF> IN PAGE MARK*)
END;
IF list←code THEN
BEGIN
IF dp THEN
write(list,lc:6:o,showrelo[(lc >= low←start) AND (level <= 1)])
ELSE
write(list,ic:6:o,'''');
write(list,' ':2)
END;
IF lptfile THEN
BEGIN
IF linenr='-----' THEN
write(list,linecnt:5)
ELSE
write(list,linenr) ;
write(list,' ':3)
END
END (*GETNEXTLINE*);
PROCEDURE endofline;
VAR
i,k: integer;
BEGIN (*ENDOFLINE*)
IF chcnt > chcntmax THEN
chcnt := chcntmax;
IF lptfile THEN
writeln(list,buffer:chcnt);
IF errorinline THEN
(*OUTPUT ERROR MESSAGES*)
BEGIN
IF error←in←heading THEN
BEGIN
writeln(tty);
error←in←heading := false;
END;
IF list←code THEN
k := 11
ELSE
k := 2;
IF lptfile THEN
write(list,' ':k,'***** ');
list←code := false;
IF linenr = '-----' THEN
write(tty,linecnt:5)
ELSE
write(tty,linenr);
writeln(tty,' ':3,buffer:chcnt); write(tty,'PAGE ',pagecnt:3); (* 13.*)
IF lptfile THEN
writeln(list,errline : chcnt);
writeln(tty,errline : chcnt);
FOR k := 1 TO errinx DO
WITH errlist[k] DO
BEGIN
IF lptfile THEN
write(list,' ':15,arw:1,'.',tic,': ');
write(tty,arw:1,'.',tic,': ');
IF errmptr <> NIL THEN
BEGIN
errmptr1 := errmptr;
REPEAT
WITH errmptr1↑ DO
IF nmr = number THEN
BEGIN
IF lptfile THEN
write(list,string:10,' - ');
write(tty,string:10,' - ');
number := 0; errmptr1 := NIL
END
ELSE
errmptr1 := next
UNTIL errmptr1 = NIL
END;
i := nmr MOD 50;
CASE nmr DIV 50 OF
3:
BEGIN
IF lptfile THEN
write(list,errmess15[i]);
write(tty,errmess15[i])
END;
4:
BEGIN
IF lptfile THEN
write(list,errmess20[i]);
write(tty,errmess20[i])
END;
5:
BEGIN
IF lptfile THEN
write(list,errmess25[i]);
write(tty,errmess25[i])
END;
6:
BEGIN
IF lptfile THEN
write(list,errmess30[i]);
write(tty,errmess30[i])
END;
7:
BEGIN
IF lptfile THEN
write(list,errmess35[i]);
write(tty,errmess35[i])
END;
8:
BEGIN
IF lptfile THEN
write(list,errmess40[i]);
write(tty,errmess40[i])
END;
9:
BEGIN
IF lptfile THEN
write(list,errmess45[i]);
write(tty,errmess45[i])
END;
10:
BEGIN
IF lptfile THEN
write(list,errmess50[i]);
write(tty,errmess50[i])
END;
11:
BEGIN
IF lptfile THEN
write(list,errmess55[i]);
write(tty,errmess55[i])
END
END;
IF lptfile THEN
writeln(list);
writeln(tty)
END;
break(tty); errinx := 0; errorinline := false;
FOR i := 1 TO chcnt DO errline [i] := ' ';
errmptr := NIL
END;
readln(source);
linecnt := linecnt + 10; chcnt := 0;
IF error←exit THEN
IF first←symbol THEN
GOTO 0
ELSE
GOTO 111
ELSE
BEGIN
IF NOT eof(source) THEN
getnextline
ELSE
BEGIN
IF NOT first←symbol THEN
error(267);
error←exit := true;
endofline
END
END
END (*ENDOFLINE*) ;
PROCEDURE error←with←text ( ferrnr: integer; ftext: alfa ) ;
BEGIN (*ERROR←WITH←TEXT*)
error(ferrnr); new(errmptr1);
WITH errmptr1↑ DO
BEGIN
number := ferrnr; string := ftext;
next := errmptr
END;
errmptr := errmptr1
END (*ERROR←WITH←TEXT*) ;
PROCEDURE warning (ferrnr: integer);
BEGIN (* WARNING *)
error←with←text (ferrnr,' WARNING: ');
errorcount := errorcount - 1;
IF errorcount = 0 THEN
error←flag := false;
END (* WARNING *);
PROCEDURE insymbol;
(*READ NEXT BASIC SYMBOL OF SOURCE PROGRAM AND RETURN ITS
DESCRIPTION IN THE GLOBAL VARIABLES SY, OP, ID, VAL AND LGTH*)
LABEL
111,
222;
CONST
maxdigits = 12;
max8 = 37777777777B;
test8 = 40000000000B;
max10 = 3435973836; (* MAXINT = 2 ** 35 - 1 = 34.359.738.367 *)
max16 = 17777777777B;
test16 = 20000000000B;
maxexp2 = 127; (* MAXREAL = 777.777.777B * 2 ** 100 *)
log←of←2 = 0.30102999806;
VAR
i, k, scale, exponent, ival: integer;
rval, r, fac: real;
stringtoolong, sign: boolean;
digit: ARRAY [1..maxdigits] OF 0..9;
string: ARRAY [1..strglgth] OF char;
lvp: csp;
PROCEDURE nextch;
BEGIN (*NEXTCH*)
IF eoln(source) THEN
ch := ' '
ELSE
BEGIN
ch := source↑; get(source);
chcnt := chcnt + 1;
IF chcnt <= chcntmax THEN
buffer[chcnt] := ch
ELSE
IF chcntmax = 72 THEN
nextch
END
END (*NEXTCH*);
(* 3. DISTINGUISH ONE-CHAR FROM TWO-CHAR LONG END OF COMMENT.*)
PROCEDURE skipcomment (onechar: boolean);
VAR
commentend: boolean;
PROCEDURE options;
VAR
lch : char;
lswitch : boolean;
lvalue : integer;
BEGIN (*OPTIONS*)
REPEAT
lvalue := 0; lswitch := false;
nextch; lch := ch;
IF NOT (ch IN ['\','*']) THEN
nextch;
IF ch IN (['+','-'] + digits) THEN
BEGIN
IF ch IN ['+','-'] THEN
BEGIN
lswitch := ch = '+'; nextch
END
ELSE
REPEAT
lvalue := lvalue * 10 + (ord(ch)-ord('0'));
nextch
UNTIL NOT (ch IN digits);
IF NOT reset←possible AND (lch IN ['S','R','X','F','I','U','E','V','Y']) (* 8. ALLOY FOR OPTION V AND Y.*) THEN
error(203)
ELSE
CASE lch OF
'L':
list←code := lswitch AND lptfile;
'U':
IF lswitch THEN
(* 13. ONLY IF IT IS 'U+'.*)
chcntmax := 72;
'T':
runtime←check := lswitch;
'E':
IF program←count > 1 THEN
error(203)
ELSE
BEGIN
external := lswitch;
IF external THEN
(* 13. CANCEL LOAD←AND←GO.*)
load←and←go := false;
END;
'D' ,'P':
IF reset←possible THEN
BEGIN
debug := lswitch;
debug←switch := lswitch
END
ELSE
IF debug THEN
debug←switch := lswitch
ELSE
error(203);
'F':
IF lvalue IN [1..max←file] THEN
start←channel := lvalue + namax[stdfile] - 2
ELSE
error(203);
'R':
runcore := lvalue;
'X':
IF lvalue IN [regin..within] THEN
parregcmax := lvalue
ELSE
error(203);
'S':
code←size := lvalue;
'I':
fortran←enviroment := lswitch;
(* 8. SET THE VERSION NUMBER.*)
'V':
goodversion := lvalue;
'Y':
resettty := lswitch;
OTHERS:
IF lch = 'B' THEN
warning(169)
ELSE
error(203)
END
END
ELSE
error(203);
IF eoln(source) THEN
endofline
UNTIL ch <> ','
END (*OPTIONS*) ;
BEGIN (*SKIPCOMMENT*)
commentend := false; nextch;
IF ch = '$' THEN
options;
(* 3. TREAT '%'-backslash COMMENTS DIFFERENTLY.*)
IF onechar THEN
IF ord(ch)-ord('0') = goodversion THEN
incondcomp := true
ELSE
WHILE ch <> '\' DO
BEGIN
IF eoln (source) THEN
endofline;
nextch;
END
ELSE
LOOP
WHILE ch = '*' DO
BEGIN
nextch;
commentend := ch = ')'
END
EXIT IF commentend; (* 3.*)
IF eoln(source) THEN
endofline;
nextch
END (*LOOP*);
nextch
END (*SKIPCOMMENT*);
BEGIN (*INSYMBOL*)
111: (* 2. *)
WHILE ch = ' ' DO
BEGIN
IF eoln(source) THEN
endofline;
nextch
END;
CASE ch OF
'%':
BEGIN
skipcomment (true); GOTO 111;
END;
'(':
BEGIN
nextch;
IF ch = '*' THEN
BEGIN
skipcomment (false); GOTO 111; (* 2.,3.*)
END
ELSE
BEGIN
sy := lparent; op := noop
END
END;
'A','B','C','D','E','F','G','H','I','J','K','L','M',
'N','O','P','Q','R','S','T','U','V','W','X','Y',
'Z':
BEGIN
k := 0 ; id := ' ';
REPEAT
IF k < alfalength THEN
BEGIN
k := k + 1; id[k] := ch
END ;
nextch
UNTIL NOT (ch IN lettersdigitsorleftarrow);
FOR i := frw[k] TO frw[k+1] - 1 DO
IF rw[i] = id THEN
BEGIN
sy := rsy[i];
op := rop[i];
IF (sy = initprocsy) AND NOT dp THEN
error(363);
GOTO 222
END;
sy := ident; op := noop;
222:
END;
'0','1','2','3','4','5','6','7','8',
'9':
BEGIN
sy := intconst; op := noop;
id := ' ';
i := 0;
REPEAT
i := i + 1;
(* THE DIGITS OF AN "INTCONST" ARE STORED AS "IDENT" TOO. THIS ALLOWES
TO ENTER "LABELS" LIKE ALL OTHER IDENTIFIERS INTO THE BINARY-
(IDENTIFIER-)TREE VIA "ENTERID" AND LOCATE THEM VIA
"SEARCHID". SO "LABELS" ARE "KNOWN" AS CONSTANTS, TYPES OR
VARIABLES IN THE BLOCK THEY HAVE BEEN DECLARED IN.
IT IS ALSO POSSIBLE TO "EXIT" FROM A BLOCK, JUMPING TO A LABEL
WHICH IS DECLARED ON A LOWER LEVEL *)
IF i <= alfalength THEN
id[i] := ch;
IF i <= maxdigits THEN
digit[i] := ord(ch) - ord('0')
ELSE
error(174) ;
nextch
UNTIL NOT (ch IN digits);
ival := 0;
IF ch = 'B' THEN
BEGIN
FOR k := 1 TO i DO
IF ival <= max8 THEN
BEGIN
IF digit[k] IN [8,9] THEN
error(252);
ival := 8*ival + digit[k]
END
ELSE
IF (ival = test8) AND (digit[12] = 0) THEN
ival := -maxint - 1
ELSE
BEGIN
error(204); ival := 0
END;
val.ival := ival;
nextch
END
ELSE
BEGIN
FOR k := 1 TO i DO
IF ival <= max10 THEN
IF (ival = max10) AND (digit[k] > 7) THEN
BEGIN
error(204); ival := 0
END
ELSE
ival := 10*ival + digit[k]
ELSE
BEGIN
error(204); ival := 0
END;
scale := 0;
IF ch = '.' THEN
BEGIN
nextch;
IF ch = '.' THEN
ch := ':'
ELSE
BEGIN
rval := ival; sy := realconst;
IF NOT (ch IN digits) THEN
error(205)
ELSE
REPEAT
rval := 10.0*rval + (ord(ch) - ord('0'));
scale := scale - 1; nextch
UNTIL NOT (ch IN digits)
END
END;
IF ch = 'E' THEN
BEGIN
IF scale = 0 THEN
BEGIN
rval := ival; sy := realconst
END;
nextch;
sign := ch='-';
IF (ch='+') OR sign THEN
nextch;
exponent := 0;
IF NOT (ch IN digits) THEN
error(205)
ELSE
REPEAT
exponent := 10 * exponent + ord(ch) - ord('0');
nextch
UNTIL NOT (ch IN digits);
IF sign THEN
scale := scale - exponent
ELSE
scale := scale + exponent;
IF abs(round(scale/log←of←2 + expo(rval))) >= maxexp2 THEN
BEGIN
error(206); scale := 0
END
END;
IF scale <> 0 THEN
BEGIN
IF scale < 0 THEN
BEGIN
scale := abs(scale); fac := 0.1
END
ELSE
fac := 10.0;
r := 1.0;
LOOP
IF odd(scale) THEN
r := r * fac;
scale := scale DIV 2
EXIT IF scale = 0;
fac := sqr(fac)
END;
rval := rval * r (* RVAL := RVAL * 10 ** SCALE *)
END;
IF sy = intconst THEN
val.ival := ival
ELSE
BEGIN
new(lvp,reel);
lvp↑.rval := rval; val.valp := lvp
END
END
END;
'"':
BEGIN
sy := intconst; op := noop; ival := 0;
nextch;
WHILE (ch IN hexadigits) AND (ival >= 0) DO
BEGIN
IF ival <= max16 THEN
IF ch IN digits THEN
ival := 16*ival + (ord(ch) - ord('0'))
ELSE
ival := 16*ival + (ord(ch) - 67B)
ELSE
IF (ival = test16) AND (ch = '0') THEN
ival := -maxint - 1
ELSE
BEGIN
error(174); ival := 0
END;
nextch
END;
WHILE ch IN hexadigits DO nextch;
val.ival := ival
END;
'''':
BEGIN
lgth := 0; sy := stringconst; op := noop; stringtoolong := false;
REPEAT
REPEAT
nextch;
IF lgth <= strglgth THEN
BEGIN
lgth := lgth + 1;
IF lgth <= strglgth THEN
string[lgth] := ch
END
ELSE
stringtoolong := true
UNTIL eoln(source) OR (ch = '''');
IF stringtoolong THEN
error(301);
IF ch <> '''' THEN
error(351)
ELSE
nextch
UNTIL ch <> '''';
lgth := lgth - 1;
IF lgth = 1 THEN
val.ival := ord(string[1])
ELSE
BEGIN
new(lvp,strg:lgth);
WITH lvp↑ DO
BEGIN
slgth := lgth;
pack(string,1,sval,1,lgth)
END;
val.valp := lvp
END
END;
':':
BEGIN
op := noop; nextch;
IF ch = '=' THEN
BEGIN
sy := becomes; nextch
END
ELSE
sy := colon
END;
'.':
BEGIN
op := noop; nextch;
IF ch = '.' THEN
BEGIN
sy := colon; nextch
END
ELSE
sy := period
END;
'<','>':
BEGIN
sy := relop; op := sop[ch]; nextch;
IF (op=ltop) AND (ch='>') THEN
BEGIN
op := neop; nextch
END
ELSE
IF ch = '=' THEN
BEGIN
IF op = ltop THEN
op := leop
ELSE
op := geop;
nextch
END
END;
(* 8. ALLOW THE backslash AT END OF A CONDITIONALY COMPILED PART.*)
'\':
IF incondcomp THEN
BEGIN
incondcomp := false;
nextch;
GOTO 111;
END
ELSE
BEGIN
sy := ssy[ch]; op := sop[ch];
nextch;
END;
OTHERS:
BEGIN
sy := ssy[ch]; op := sop[ch];
nextch
END
END (*CASE*);
first←symbol := false;
END (*INSYMBOL*) ;
PROCEDURE searchsection(fcp: ctp; VAR fcp1: ctp);
(*TO FIND RECORD FIELDS AND FORWARD DECLARED PROCEDURE ID'S
--> PROCEDURE PROCEDUREDECLARATION
--> PROCEDURE SELECTOR*)
LABEL
333;
BEGIN (*SEARCHSECTION*)
WHILE fcp <> NIL DO
WITH fcp↑ DO
BEGIN
IF name = id THEN
GOTO 333;
IF name < id THEN
fcp := rlink
ELSE
fcp := llink
END;
333:
fcp1 := fcp
END (*SEARCHSECTION*) ;
PROCEDURE searchid(fidcls: setofids; VAR fcp: ctp);
LABEL
444;
VAR
lcp: ctp;
BEGIN (*SEARCHID*)
FOR disx := top DOWNTO 0 DO
BEGIN
lcp := display[disx].fname;
WHILE lcp <> NIL DO
WITH lcp↑ DO
IF name = id THEN
IF klass IN fidcls THEN
GOTO 444
ELSE
BEGIN
IF search←error THEN
error(401);
lcp := rlink
END
ELSE
IF name < id THEN
lcp := rlink
ELSE
lcp := llink
END;
(*SEARCH NOT SUCCSESSFUL; SUPPRESS ERROR MESSAGE IN CASE
OF FORWARD REFERENCED TYPE ID IN POINTER TYPE DEFINITION
--> PROCEDURE SIMPLETYPE*)
IF search←error THEN
BEGIN
IF id[1] IN digits THEN
error(215) (*UNDECLARED LABEL*)
ELSE
error(253) (*UNDECLARED IDENTIFIER*);
(*TO AVOID RETURNING NIL, REFERENCE AN ENTRY
FOR AN UNDECLARED ID OF APPROPRIATE CLASS
--> PROCEDURE ENTERUNDECL*)
IF types IN fidcls THEN
lcp := utypptr
ELSE
IF vars IN fidcls THEN
lcp := uvarptr
ELSE
IF field IN fidcls THEN
lcp := ufldptr
ELSE
IF konst IN fidcls THEN
lcp := ucstptr
ELSE
IF proc IN fidcls THEN
lcp := uprcptr
ELSE
lcp := ufctptr
END;
444:
fcp := lcp
END (*SEARCHID*) ;
PROCEDURE skipiferr(fsyinsys:setofsys; ferrnr:integer; fskipsys: setofsys);
VAR
i,oldchcnt,oldlinecnt : integer;
BEGIN (*SKIPIFERR*)
IF NOT (sy IN fsyinsys) THEN
BEGIN
error(ferrnr);
oldlinecnt := linecnt; oldchcnt := chcnt;
WHILE NOT (sy IN fskipsys + fsyinsys) DO
BEGIN
(*SKIP INPUT STRING UNTIL RELEVANT SYMBOL FOUND*)
IF oldlinecnt <> linecnt THEN
oldchcnt := 1;
FOR i := oldchcnt TO chcnt-1 DO
IF i <= chcntmax THEN
errline [i] := '*';
oldchcnt := chcnt; oldlinecnt := linecnt; errorinline := true;
insymbol
END
END;
followerror := false
END (*SKIPIFERR*);
PROCEDURE iferrskip(ferrnr: integer; fsys: setofsys);
BEGIN (*IFERRSKIP*)
skipiferr(fsys,ferrnr,fsys)
END (*IFERRSKIP*);
PROCEDURE errandskip(ferrnr: integer; fsys: setofsys);
BEGIN (*ERRANDSKIP*)
skipiferr([ ],ferrnr,fsys)
END (*ERRANDSKIP*);
(* BLOCK[ AUXILIAR PROCEDURES FOR TYPE CHECKING. *)
PROCEDURE block(fprocp: ctp; fsys,leaveblocksys: setofsys);
TYPE
marker = ↑integer;
VAR
lsy: symbol; current←jump: 0..jump←max;
testpacked: boolean;
lcpar: addrrange;
heapmark, globmark: marker;
forward←procedures : ctp;
PROCEDURE constant(fsys: setofsys; VAR fsp: stp; VAR fvalu: valu);
VAR
lsp, lsp1: stp;
lcp: ctp;
sign: (none,pos,neg);
BEGIN (*CONSTANT*)
lsp := NIL; fvalu.ival := 0;
skipiferr(constbegsys,207,fsys);
IF sy IN constbegsys THEN
BEGIN
IF sy = stringconst THEN
BEGIN
IF lgth = 1 THEN
lsp := asciiptr
ELSE
IF lgth = alfalength THEN
lsp := alfaptr
ELSE
BEGIN
new(lsp,arrays); new(lsp1,subrange);
WITH lsp↑ DO
BEGIN
selfstp := NIL; aeltype := asciiptr; inxtype := lsp1;
size := (lgth+4) DIV 5; arraypf := true;
bitsize := bitmax
END;
WITH lsp1↑ DO
BEGIN
selfstp := NIL; size := 1; bitsize := bitmax;
vmin.ival := 1; vmax.ival := lgth; rangetype := intptr
END
END;
fvalu := val; insymbol
END
ELSE
BEGIN
sign := none;
IF (sy = addop) AND (op IN [plus,minus]) THEN
BEGIN
IF op = plus THEN
sign := pos
ELSE
sign := neg;
insymbol
END;
IF sy = ident THEN
BEGIN
searchid([konst],lcp);
WITH lcp↑ DO
BEGIN
lsp := idtype; fvalu := values
END;
IF sign <> none THEN
IF lsp = intptr THEN
BEGIN
IF sign = neg THEN
fvalu.ival := -fvalu.ival
END
ELSE
IF lsp = realptr THEN
BEGIN
IF sign = neg THEN
fvalu.valp↑.rval := -fvalu.valp↑.rval
END
ELSE
error(167);
insymbol
END
ELSE
IF sy = intconst THEN
BEGIN
IF sign = neg THEN
val.ival := -val.ival;
lsp := intptr; fvalu := val; insymbol
END
ELSE
IF sy = realconst THEN
BEGIN
IF sign = neg THEN
val.valp↑.rval := -val.valp↑.rval;
lsp := realptr; fvalu := val; insymbol
END
ELSE
errandskip(168,fsys)
END;
iferrskip(166,fsys)
END;
fsp := lsp
END (*CONSTANT*) ;
PROCEDURE getbounds(fsp: stp; VAR fmin, fmax: integer);
FORWARD;
FUNCTION string(fsp: stp) : boolean;
FORWARD; (* 25.*)
FUNCTION comptypes(fsp1,fsp2: stp) : boolean;
(*DECIDE WHETHER STRUCTURES POINTED AT BY FSP1 AND FSP2 ARE COMPATIBLE*)
VAR
nxt1,nxt2: ctp; comp: boolean; lmin,lmax,i: integer;
ltestp1,ltestp2: testp;
lsstrp: sstrptr; (* 25.*)
(* 25. TO KEEP THE LENGTH OF PACKED ARRAYS OF CHAR, FOR STRING PROCEDURE CALLS.*)
FUNCTION checksstring(fsp: stp) : boolean;
VAR
lmin, lmax: integer;
ok: boolean;
FUNCTION ismagic (name: alfa; fkind: namekind; ffirst,flast: integer) : boolean;
VAR
index: integer;
BEGIN (*ISMAGIC*)
ismagic := false;
index := ffirst;
WHILE index <= flast DO
IF name = na[fkind, index] THEN
BEGIN
ismagic := true;
index := flast + 1;
END
ELSE
index := index + 1;
END (*ISMAGIC*);
BEGIN (*CHECKSSTRING*)
checksstring := false;
IF pctp↑.klass = proc THEN
ok := ismagic(pctp↑.name,declproc,14,17) (* PUTCHAR TO CONCAT *)
ELSE
ok := ismagic(pctp↑.name,declfunc,21,29);
(* LENGTH TO STRNE *)
IF ok THEN
IF string(fsp) THEN
BEGIN
IF fsp↑.arraypf THEN
BEGIN
checksstring := true;
getbounds(fsp↑.inxtype,lmin,lmax);
sstringlength↑.value[sstringlength↑.count] := lmax-lmin+1;
END
END
ELSE
IF comptypes (fsp,asciiptr) THEN
BEGIN
checksstring := true;
sstringlength↑.value[sstringlength↑.count] := 1;
END;
END (*CHECKSSTRING*);
(* 25.*)
BEGIN (*COMPTYPES*)
(* 25. COUNT THE SSTRINGS THAT ARE CHECKED *)
IF stringpack THEN
IF parsingparameters THEN
IF (fsp1 = sstringptr) OR (fsp2 = sstringptr) THEN
IF NOT recall THEN
BEGIN
recall := true;
IF sstringstart THEN
BEGIN
new(lsstrp);
WITH lsstrp↑ DO
BEGIN
next := sstringlength; count := 0;
value[1] := xtrastrglgth; value[2] := xtrastrglgth;
END;
sstringlength := lsstrp;
sstringstart := false;
END;
sstringlength↑.count := sstringlength↑.count + 1;
END;
(* 25.*)
IF fsp1 = fsp2 THEN
comptypes := true
ELSE
IF (fsp1 <> NIL) AND (fsp2 <> NIL) THEN
IF fsp1↑.form = fsp2↑.form THEN
CASE fsp1↑.form OF
scalar:
comptypes := false;
(* IDENTICAL SCALARS DECLARED ON DIFFERENT LEVELS ARE
NOT RECOGNIZED TO BE COMPATIBLE*)
subrange:
comptypes := comptypes(fsp1↑.rangetype,fsp2↑.rangetype);
pointer:
BEGIN
comp := false; ltestp1 := globtestp; ltestp2 := globtestp;
WHILE ltestp1 <> NIL DO
WITH ltestp1↑ DO
BEGIN
IF (elt1 = fsp1↑.eltype) AND (elt2 = fsp2↑.eltype) THEN
comp := true;
ltestp1 := lasttestp
END;
IF NOT comp THEN
BEGIN
new(ltestp1);
WITH ltestp1↑ DO
BEGIN
elt1 := fsp1↑.eltype;
elt2 := fsp2↑.eltype;
lasttestp := globtestp
END;
globtestp := ltestp1; comp := comptypes(fsp1↑.eltype,fsp2↑.eltype)
END;
comptypes := comp; globtestp := ltestp2
END;
power:
comptypes := comptypes(fsp1↑.elset,fsp2↑.elset);
arrays:
BEGIN
getbounds(fsp1↑.inxtype,lmin,lmax);
i := lmax-lmin;
getbounds(fsp2↑.inxtype,lmin,lmax);
comptypes := comptypes(fsp1↑.aeltype,fsp2↑.aeltype)
AND (fsp1↑.arraypf = fsp2↑.arraypf) AND ( i = lmax - lmin ) ;
END;
records:
BEGIN
nxt1 := fsp1↑.fstfld; nxt2 := fsp2↑.fstfld; comp := true;
WHILE (nxt1 <> NIL) AND (nxt2 <> NIL) DO
BEGIN
comp := comptypes(nxt1↑.idtype,nxt2↑.idtype) AND comp;
nxt1 := nxt1↑.next; nxt2 := nxt2↑.next
END;
comptypes := comp AND (nxt1 = NIL) AND (nxt2 = NIL)
AND (fsp1↑.recvar = NIL) AND (fsp2↑.recvar = NIL)
END;
(*IDENTICAL RECORDS ARE RECOGNIZED TO BE COMPATIBLE
IF NO VARIANTS OCCUR*)
files:
comptypes := comptypes(fsp1↑.filtype,fsp2↑.filtype)
END (*CASE*)
ELSE
(*FSP1↑.FORM <> FSP2↑.FORM*)
IF fsp1↑.form = subrange THEN
comptypes := comptypes(fsp1↑.rangetype,fsp2)
ELSE
IF fsp2↑.form = subrange THEN
comptypes := comptypes(fsp1,fsp2↑.rangetype)
ELSE
(* 25. ACCEPT PACKED ARRAYS OF CHAR AND CHAR AS SSTRINGS.*)
IF stringpack AND parsingparameters THEN
IF fsp1 = sstringptr THEN
comptypes := checksstring(fsp2)
ELSE
comptypes := false
ELSE
comptypes := false
ELSE
comptypes := true
END (*COMPTYPES*) ;
PROCEDURE getbounds; (* (FSP: STP; VAR FMIN, FMAX: INTEGER) *)
(*GET INTERNAL BOUNDS OF SUBRANGE OR SCALAR TYPE*)
BEGIN (*GETBOUNDS*)
fmin := 0; fmax := 0;
IF fsp <> NIL THEN
IF fsp = intptr THEN
BEGIN (* TYPE INTEGER = MININT..MAXINT *)
fmin := -maxint - 1;
fmax := maxint
END
ELSE
IF (fsp↑.form <= subrange) AND NOT comptypes(realptr,fsp) THEN
WITH fsp↑ DO
IF form = subrange THEN
BEGIN
fmin := vmin.ival;
fmax := vmax.ival
END
ELSE
IF fsp = asciiptr THEN
BEGIN (* TYPE ASCII = NUL..DEL *)
fmin := ord(nul);
fmax := ord(del)
END
ELSE
IF fconst <> NIL THEN
fmax := fconst↑.values.ival
ELSE
fmax := 0
END (*GETBOUNDS*) ;
FUNCTION string (* (FSP: STP) : BOOLEAN *) ; (* RETURNS TRUE IF FSP DESCRIBES A PACKED ARRAY OF CHAR *)
BEGIN (*STRING*)
string := false;
IF fsp <> NIL THEN
IF fsp↑.form = arrays THEN
string := comptypes(fsp↑.aeltype,asciiptr)
END (*STRING*) ;
(* TYP (TYPE DEFINITION PARSER) *)
PROCEDURE typ(fsys: setofsys; VAR fsp: stp; VAR fsize: addrrange;
VAR fbitsize: bitrange);
VAR
lsp,lsp1,lsp2: stp; oldtop: disprange; lcp: ctp;
lsize,displ: addrrange; i,lmin,lmax: integer;
packflag: boolean; lbitsize: bitrange;
lbtp: btp; bitcount:integer; bytes: bitrange;
FUNCTION log2(fval: integer): bitrange;
VAR
e: bitrange; h: integer;
BEGIN (*LOG2*)
e := 0; h := 1;
REPEAT
e := e + 1; h := h * 2
UNTIL fval <= h;
log2 := e
END (*LOG2*);
PROCEDURE simpletype(fsys: setofsys; VAR fsp: stp; VAR fsize: addrrange;
VAR fbitsize: bitrange);
VAR
lsp,lsp1: stp; lcp,lcp1: ctp; ttop: disprange;
lcnt: integer; lvalu: valu; lbitsize: bitrange;
BEGIN (*SIMPLETYPE*)
fsize := 1;
skipiferr(simptypebegsys,208,fsys);
IF sy IN simptypebegsys THEN
BEGIN (* DECLARED SCALARS *)
IF sy = lparent THEN
BEGIN
ttop := top;
WHILE display[top].occur <> blck DO top := top - 1;
new(lsp,scalar,declared);
lcp1 := NIL; lcnt := 0;
REPEAT
insymbol;
IF sy = ident THEN
BEGIN
new(lcp,konst);
WITH lcp↑ DO
BEGIN
name := id; idtype := lsp; next := lcp1;
values.ival := lcnt
END;
enterid(lcp);
lcnt := lcnt + 1;
lcp1 := lcp; insymbol
END
ELSE
error(209);
iferrskip(166,fsys + [comma,rparent])
UNTIL sy <> comma;
top := ttop;
WITH lsp↑ DO
BEGIN
selfstp := NIL; fconst := lcp1; size := 1; bitsize := log2(lcnt);
(*ADDITIONAL INFORMATION NEEDED TO STORE IDENTS OF DECLARED
SCALARS USED BY READ AND WRITE*)
vectorchain := 0; dimension := lcnt - 1; request := false;
nextscalar := declscalptr; declscalptr := lsp;
vectoraddr := 0; tlev := level
END;
IF sy = rparent THEN
insymbol
ELSE
error(152)
END (* SY = LPARENT *)
ELSE
BEGIN (* DEFINED CONSTANTS *)
IF sy = ident THEN
BEGIN
searchid([types,konst],lcp);
insymbol;
IF lcp↑.klass = konst THEN
BEGIN
new(lsp,subrange);
WITH lsp↑, lcp↑ DO
BEGIN
selfstp := NIL; rangetype := idtype;
IF string(rangetype) THEN
BEGIN
error(303); rangetype := NIL
END;
vmin := values; size := 1
END;
IF sy = colon THEN
insymbol
ELSE
error(151);
constant(fsys,lsp1,lvalu);
WITH lsp↑ DO
BEGIN
vmax := lvalu;
IF (vmin.ival < 0) OR (rangetype = realptr) THEN
bitsize := bitmax
ELSE
IF vmax.ival = maxint THEN
bitsize := bitmax
ELSE
bitsize := log2(vmax.ival + 1);
IF NOT comptypes(rangetype,lsp1) THEN
error(304)
END
END
ELSE
BEGIN
lsp := lcp↑.idtype;
IF lsp <> NIL THEN
fsize := lsp↑.size
END
END (*SY = IDENT*)
ELSE
(* SELF-DEFINING CONSTANTS *)
BEGIN
new(lsp,subrange);
constant(fsys + [colon],lsp1,lvalu);
IF string(lsp1) THEN
BEGIN
error(303); lsp1 := NIL
END;
WITH lsp↑ DO
BEGIN
rangetype := lsp1; vmin := lvalu; size := 1
END;
IF sy = colon THEN
insymbol
ELSE
error(151);
constant(fsys,lsp1,lvalu);
WITH lsp↑ DO
BEGIN
selfstp := NIL; vmax := lvalu;
IF (vmin.ival < 0) OR (rangetype = realptr) THEN
bitsize := bitmax
ELSE
IF vmax.ival = maxint THEN
bitsize := bitmax
ELSE
bitsize := log2(vmax.ival + 1);
IF NOT comptypes(rangetype,lsp1) THEN
error(304)
END
END;
IF lsp <> NIL THEN
WITH lsp↑ DO
IF form = subrange THEN
IF rangetype <> NIL THEN
IF rangetype = realptr THEN
BEGIN
IF vmin.valp↑.rval > vmax.valp↑.rval THEN
error(451)
END
ELSE
IF vmin.ival > vmax.ival THEN
error(451)
END;
fsp := lsp;
IF lsp<>NIL THEN
fbitsize := lsp↑.bitsize
ELSE
fbitsize := 0;
iferrskip(166,fsys)
END
ELSE
BEGIN
fsp := NIL; fbitsize := 0
END
END (*SIMPLETYPE*) ;
PROCEDURE fieldlist(fsys: setofsys; VAR frecvar: stp; VAR ffirstfield: ctp);
LABEL
555;
VAR
lcp,lcp1,nxt,nxt1: ctp; lsp,lsp1,lsp2,lsp3,lsp4,tagsp: stp;
minsize,maxsize,lsize: addrrange; lvalu: valu;
lbitsize: bitrange;
lbtp: btp; minbitcount:integer;
lid : alfa ;
PROCEDURE recsection( VAR fcp: ctp; fsp: stp );
BEGIN (*RECSECTION*)
IF NOT packflag OR (lsize > 1) OR (lbitsize = 36) THEN
BEGIN
IF bitcount > 0 THEN
BEGIN
displ := displ + 1; bitcount := 0
END;
WITH fcp↑ DO
BEGIN
idtype := fsp; fldaddr := displ;
packf := notpack; fcp := next;
displ := displ + lsize
END
END
ELSE
(*PACKED RECORDS*)
BEGIN
bitcount := bitcount + lbitsize;
IF bitcount>bitmax THEN
BEGIN
displ := displ + 1;
bitcount := lbitsize
END;
IF (lbitsize = 18) AND (bitcount IN [18,36]) THEN
BEGIN
WITH fcp↑ DO
BEGIN
idtype := fsp;
fldaddr := displ;
IF bitcount = 18 THEN
packf := hwordl
ELSE
packf := hwordr;
fcp := next
END
END
ELSE
WITH fcp↑, fldbyte DO
BEGIN
sbits := lbitsize;
pbits := bitmax - bitcount;
reladdr := displ;
dummybit := 0;
ibit := 0;
idtype := fsp;
packf := packk;
fcp := next
END
END
END (* RECSECTION *) ;
BEGIN (* FIELDLIST *)
nxt1 := NIL; lsp := NIL;
(* 13. ALLOW EXTRA SEMICOLONS AND NULL FIELDLISTS *)
WHILE sy = semicolon DO
insymbol;
skipiferr(fsys + [ident,casesy],452,fsys);
WHILE sy = ident DO
BEGIN
nxt := nxt1;
LOOP
IF sy = ident THEN
BEGIN
new(lcp,field);
WITH lcp↑ DO
BEGIN
name := id; idtype := NIL; next := nxt
END;
nxt := lcp;
enterid(lcp);
insymbol
END
ELSE
error(209);
skipiferr([comma,colon],166,fsys + [semicolon,casesy])
EXIT IF sy <> comma ;
insymbol
END;
IF sy = colon THEN
insymbol
ELSE
error(151);
typ(fsys + [casesy,semicolon],lsp,lsize,lbitsize);
IF lsp <> NIL THEN
IF lsp↑.form = files THEN
error(254);
(* RESERVE SPACE FOR ONE RECORD SECTION *)
WHILE nxt <> nxt1 DO
recsection(nxt,lsp);
nxt1 := lcp;
(* 13. ALLOW NULL ENTRIES.*)
WHILE sy = semicolon DO
BEGIN
insymbol;
skipiferr(fsys + [ident,casesy,semicolon],452,fsys);
END;
END (*WHILE*);
nxt := NIL;
WHILE nxt1 <> NIL DO
WITH nxt1↑ DO
BEGIN
lcp := next; next := nxt; nxt := nxt1; nxt1 := lcp
END;
ffirstfield := nxt;
IF sy = casesy THEN
BEGIN
lcp:=NIL; (*POSSIBILITY OF NO TAGFIELD IDENTIFIER*)
insymbol;
IF sy = ident THEN
BEGIN
lid := id ;
insymbol ;
IF (sy<>colon) AND (sy<>ofsy) THEN
BEGIN
error(151) ;
errandskip(160,fsys + [lparent])
END
ELSE
BEGIN
IF sy = colon THEN
BEGIN
new(lsp,tagfwithid);
new(lcp,field) ;
WITH lcp↑ DO
BEGIN
name := lid ; idtype := NIL ; next := NIL
END ;
enterid(lcp) ;
insymbol ;
IF sy <> ident THEN
BEGIN
errandskip(209,fsys + [lparent]) ; GOTO 555
END
ELSE
BEGIN
lid := id ;
insymbol ;
IF sy <> ofsy THEN
BEGIN
errandskip(160,fsys + [lparent]) ; GOTO 555
END
END
END
ELSE
new(lsp,tagfwithoutid) ;
WITH lsp↑ DO
BEGIN
size:= 0 ; selfstp := NIL ;
fstvar := NIL;
IF form=tagfwithid THEN
tagfieldp:=NIL
ELSE
tagfieldtype := NIL
END;
frecvar := lsp;
id := lid ;
searchid([types],lcp1) ;
tagsp := lcp1↑.idtype;
IF tagsp <> NIL THEN
IF (tagsp↑.form <= subrange) OR string(tagsp) THEN
BEGIN
IF comptypes(realptr,tagsp) THEN
error(210)
ELSE
IF string(tagsp) THEN
error(169);
WITH lsp↑ DO
BEGIN
bitsize := tagsp↑.bitsize;
IF form = tagfwithid THEN
tagfieldp := lcp
ELSE
tagfieldtype := tagsp
END;
IF lcp <> NIL THEN
BEGIN
lbitsize :=tagsp↑.bitsize;
lsize := tagsp↑.size;
recsection(lcp,tagsp); (*RESERVES SPACE FOR THE TAGFIELD *)
IF bitcount > 0 THEN
lsp↑.size := displ + 1
ELSE
lsp↑.size := displ
END
END
ELSE
error(402);
insymbol
END
END
ELSE
errandskip(209,fsys + [lparent]) ;
555:
lsp1 := NIL; minsize := displ; maxsize := displ; minbitcount:=bitcount;
(* 13. ALLOW EXTRA SEMICOLONS.*)
WHILE sy = semicolon DO
insymbol;
LOOP
lsp2 := NIL;
LOOP
constant(fsys + [comma,colon,lparent],lsp3,lvalu);
IF NOT comptypes(tagsp,lsp3) THEN
error(305);
new(lsp3,variant);
WITH lsp3↑ DO
BEGIN
nxtvar := lsp1; subvar := lsp2; varval := lvalu;
bitsize := lsp↑.bitsize; selfstp := NIL
END;
lsp1 := lsp3; lsp2 := lsp3
EXIT IF sy <> comma;
insymbol
END;
IF sy = colon THEN
insymbol
ELSE
error(151);
IF sy = lparent THEN
insymbol
ELSE
error(153);
fieldlist(fsys + [rparent,semicolon],lsp2,lcp);
IF bitcount > 0 THEN
BEGIN
displ := displ + 1 ; bitcount := 0
END ;
IF displ > maxsize THEN
maxsize := displ;
WHILE lsp3 <> NIL DO
BEGIN
lsp4 := lsp3↑.subvar; lsp3↑.subvar := lsp2; lsp3↑.firstfield := lcp;
lsp3↑.size := displ ;
lsp3 := lsp4
END;
IF sy = rparent THEN
BEGIN
insymbol;
iferrskip(166,fsys + [semicolon])
END
ELSE
error(152);
(* 13. ALLOW EXTRA SEMICOLONS.*)
WHILE sy = semicolon DO
insymbol;
EXIT IF sy IN fsys;
displ := minsize;
bitcount := minbitcount;
END;
displ := maxsize;
lsp↑.fstvar := lsp1
END (*IF SY = CASESY*)
ELSE
IF lsp <> NIL THEN
IF lsp↑.form = arrays THEN
frecvar := lsp
ELSE
frecvar := NIL
END (*FIELDLIST*) ;
BEGIN (*TYP*)
skipiferr(typebegsys,170,fsys);
IF sy IN typebegsys THEN
BEGIN
IF sy IN simptypebegsys THEN
simpletype(fsys,fsp,fsize,fbitsize)
ELSE
IF sy = arrow THEN
BEGIN
new(lsp,pointer); fsp := lsp;
lbitsize := 18;
WITH lsp↑ DO
BEGIN
selfstp := NIL; eltype := NIL; size := 1; bitsize := lbitsize
END;
insymbol;
IF sy = ident THEN
BEGIN
search←error := false;
searchid([types],lcp);
search←error := true;
IF lcp = NIL THEN
(*FORWARD REFERENCED TYPE ID*)
BEGIN
new(lcp,types);
WITH lcp↑ DO
BEGIN
name := id; idtype := lsp;
next := forward←pointer←type
END;
forward←pointer←type := lcp
END
ELSE
BEGIN
IF lcp↑.idtype <> NIL THEN
IF lcp↑.idtype↑.form = files THEN
error(254)
ELSE
lsp↑.eltype := lcp↑.idtype
END;
insymbol;
fbitsize:=18
END
ELSE
error(209)
END
ELSE
BEGIN
IF sy = segmentsy THEN
BEGIN
error (169); (* 13.*)
insymbol;
skipiferr(typedels + [packedsy],170,fsys)
END;
IF sy = packedsy THEN
BEGIN
insymbol;
skipiferr(typedels,170,fsys);
packflag := true
END
ELSE
packflag := false;
CASE sy OF
arraysy:
BEGIN
insymbol;
IF sy = lbrack THEN
insymbol
ELSE
error(154);
lsp1 := NIL;
LOOP
new(lsp,arrays);
WITH lsp↑ DO
BEGIN
aeltype := lsp1; inxtype := NIL; selfstp := NIL;
arraypf := packflag; size := 1
END;
lsp1 := lsp;
simpletype(fsys + [comma,rbrack,ofsy],lsp2,lsize,lbitsize);
IF lsp2 <> NIL THEN
IF lsp2↑.form <= subrange THEN
BEGIN
IF lsp2 = realptr THEN
BEGIN
error(210); lsp2 := NIL
END
ELSE
IF lsp2 = intptr THEN
BEGIN
error(306); lsp2 := NIL
END;
lsp↑.inxtype := lsp2
END
ELSE
BEGIN
error(403); lsp2 := NIL
END
EXIT IF sy <> comma;
insymbol
END;
IF sy = rbrack THEN
insymbol
ELSE
error(155);
IF sy = ofsy THEN
insymbol
ELSE
error(160);
typ(fsys,lsp,lsize,lbitsize);
IF lsp <> NIL THEN
IF lsp↑.form = files THEN
error(169) ;
REPEAT
WITH lsp1↑ DO
BEGIN
lsp2 := aeltype; aeltype := lsp;
IF inxtype <> NIL THEN
BEGIN
getbounds(inxtype,lmin,lmax);
i := lmax - lmin + 1;
IF arraypf AND (lbitsize<=18) THEN
BEGIN
bytes := bitmax DIV lbitsize;
WITH arraybps[lbitsize] DO
IF state = used THEN
arraybpaddr := address
ELSE
BEGIN
new(lbtp);
WITH lbtp↑ DO
BEGIN
last := lastbtp; bitsize := lbitsize;
bytemax := bytes + 1 (*ONE MORE BYTEPOINTER USED FOR INCREMENT-OPERATIONS*) ;
arraysp := lsp1
END;
lastbtp := lbtp;
IF state = unused THEN
BEGIN
state := requested;
WITH abyte DO
BEGIN
sbits := lbitsize;
pbits := bitmax; dummybit := 0;
ibit := 0; ireg := reg1; reladdr := 0
END
END
END;
lsize := (i+bytes-1) DIV (bytes)
END
ELSE
BEGIN
lsize := lsize * i;
arraypf := false
END;
lbitsize := bitmax;
bitsize := lbitsize;
size := lsize
END
END;
lsp := lsp1; lsp1 := lsp2
UNTIL lsp1 = NIL
END;
recordsy:
BEGIN
insymbol;
oldtop := top;
IF top < displimit THEN
BEGIN
top := top + 1; display[top].fname := NIL ;
display[top].occur := crec ;
END
ELSE
error(404);
displ := 0; bitcount := 0;
fieldlist(fsys-[semicolon] + [endsy],lsp1,lcp);
lbitsize := bitmax;
new(lsp,records);
WITH lsp↑ DO
BEGIN
selfstp := NIL;
fstfld := (*LCP;*) display[top].fname;
recvar := lsp1;
IF bitcount > 0 THEN
size := displ + 1
ELSE
size := displ;
bitsize := lbitsize; recordpf := packflag
END;
top := oldtop;
IF sy = endsy THEN
insymbol
ELSE
error(163)
END;
setsy:
BEGIN
insymbol;
IF sy = ofsy THEN
insymbol
ELSE
error(160);
simpletype(fsys,lsp1,lsize,lbitsize);
IF lsp1 <> NIL THEN
WITH lsp1↑ DO
CASE form OF
scalar:
IF scalkind = standard THEN
error(268)
ELSE
IF fconst↑.values.ival > basemax THEN
error(268);
subrange:
IF comptypes(rangetype,asciiptr) THEN
BEGIN
IF ((vmax.ival-offset) > basemax) OR ((vmin.ival-offset) < 0) THEN
error(268)
END
ELSE
BEGIN
IF (rangetype = realptr) OR
((vmax.ival > basemax) OR (vmin.ival < 0)) THEN
error(268)
END;
OTHERS:
BEGIN
error(461); lsp1 := NIL
END
END;
lbitsize := bitmax;
new(lsp,power);
WITH lsp↑ DO
BEGIN
selfstp := NIL; elset := lsp1; size:=2; bitsize := lbitsize
END
END;
filesy:
BEGIN
insymbol;
IF sy = ofsy THEN
insymbol
ELSE
error(160);
typ(fsys,lsp1,lsize,lbitsize);
new(lsp,files);
lbitsize := bitmax;
WITH lsp↑ DO
BEGIN
selfstp := NIL;
filtype := lsp1; size := lsize+sizeoffileblock;
filepf := packflag; bitsize := lbitsize ;
(* REFER TO PROCEDURE "CODE←FOR←FILEBLOCKS"
IN "WRITE←MACHINE←CODE" *)
file←mode := binary←mode;
file←form := data←file;
IF comptypes(filtype,asciiptr) AND filepf THEN
BEGIN
file←mode := ascii←mode;
IF filtype <> NIL THEN
WITH filtype↑ DO
IF (form = subrange) AND
((vmin.ival >= ord(' ')) AND
(vmax.ival <= ord('←'))) THEN
lsp↑.file←form := text←file
END;
IF filepf AND (file←mode = binary←mode) THEN
filepf := false
END;
IF lsp1 <> NIL THEN
IF lsp1↑.form = files THEN
BEGIN
error(254); lsp↑.filtype := NIL
END
END
END (*CASE*);
fsp := lsp; fbitsize := lbitsize
END;
iferrskip(166,fsys)
END
ELSE
fsp := NIL;
IF fsp = NIL THEN
BEGIN
fsize := 1;fbitsize := 0
END
ELSE
fsize := fsp↑.size
END (*TYP*) ;
(* PARSING OF DECLARATIONS. *)
PROCEDURE labeldeclaration;
VAR
lcp: ctp;
BEGIN (*LABELDECLARATION*)
IF jumper < jump←max THEN
jumper := jumper + 1
ELSE
error(319);
current←jump := jumper;
jump←table[jumper] := 0;
LOOP
IF sy = intconst THEN
BEGIN
new(lcp,labels);
WITH lcp↑ DO
BEGIN
scope := level; name := id; idtype := NIL; next := last←label;
goto←chain := 0; label←address := 0; last←label := lcp;
jump←index := jumper; exit←jump := false;
IF val.ival > labmax THEN
error(265)
END;
enterid(lcp);
insymbol
END
ELSE
error(255);
iferrskip(166,fsys + [comma,semicolon])
EXIT IF sy <> comma;
insymbol
END;
IF sy = semicolon THEN
insymbol
ELSE
error(156)
END (*LABELDECLARATION*) ;
PROCEDURE constantdeclaration;
VAR
lcp: ctp; lsp: stp; lvalu: valu;
BEGIN (*CONSTANTDECLARATION*)
skipiferr([ident],209,fsys);
WHILE sy = ident DO
BEGIN
new(lcp,konst);
WITH lcp↑ DO
BEGIN
name := id; idtype := NIL; next := NIL
END;
insymbol;
IF (sy = relop) AND (op = eqop) THEN
insymbol
ELSE
error(157);
constant(fsys + [semicolon],lsp,lvalu);
enterid(lcp);
lcp↑.idtype := lsp; lcp↑.values := lvalu;
IF sy = semicolon THEN
BEGIN
insymbol;
iferrskip(166,fsys + [ident])
END
ELSE
error(156)
END
END (*CONSTANTDECLARATION*) ;
PROCEDURE typedeclaration;
VAR
lcp,lcp1,lcp2: ctp; lsp: stp; lsize: addrrange;
lbitsize: bitrange;
BEGIN (*CONSTANTDECLARATION*)
skipiferr([ident],209,fsys);
WHILE sy = ident DO
BEGIN
new(lcp,types);
WITH lcp↑ DO
BEGIN
name := id; next := NIL
END;
insymbol;
IF (sy = relop) AND (op = eqop) THEN
insymbol
ELSE
error(157);
typ(fsys + [semicolon],lsp,lsize,lbitsize);
enterid(lcp);
WITH lcp↑ DO
BEGIN
idtype := lsp;
(* LOOK FOR UNSATISFIED POINTER FORWARD REFERENCES;
THERE MAY BE MORE THAN ONE FOR ONE TYPE-DECLARATION *)
lcp1 := forward←pointer←type;
WHILE lcp1 <> NIL DO
BEGIN
IF lcp1↑.name = name THEN
BEGIN
IF idtype↑.form = files THEN
BEGIN
error(254);
lcp1↑.idtype↑.eltype := NIL
END
ELSE
lcp1↑.idtype↑.eltype := idtype;
IF lcp1 <> forward←pointer←type THEN
lcp2↑.next := lcp1↑.next
ELSE
forward←pointer←type := lcp1↑.next
END
ELSE
lcp2 := lcp1;
lcp1 := lcp1↑.next
END
END;
IF sy = semicolon THEN
BEGIN
insymbol;
iferrskip(166,fsys + [ident])
END
ELSE
error(156)
END;
WHILE forward←pointer←type <> NIL DO
BEGIN
error←with←text(405,forward←pointer←type↑.name);
forward←pointer←type := forward←pointer←type↑.next
END
END (*TYPEDECLARATION*) ;
PROCEDURE variabledeclaration;
VAR
lcp,nxt: ctp; lsp: stp; lsize: addrrange;
lbitsize: bitrange; lparmptr: ptp; found: boolean;
lfileptr: ftp;
BEGIN (*VARIABLEDECLARATION*)
nxt := NIL;
REPEAT
LOOP
IF sy = ident THEN
BEGIN
new(lcp,vars);
WITH lcp↑ DO
BEGIN
name := id; next := nxt;
idtype := NIL; vkind := actual; vlev := level
END;
enterid(lcp);
nxt := lcp;
insymbol
END
ELSE
error(209);
skipiferr(fsys + [comma,colon] + typedels,166,[semicolon])
EXIT IF sy <> comma;
insymbol
END;
IF sy = colon THEN
insymbol
ELSE
error(151);
typ(fsys + [semicolon] + typedels,lsp,lsize,lbitsize);
IF NOT testpacked AND (lsp <> NIL) THEN
BEGIN
IF lsp↑.form = arrays THEN
testpacked := lsp↑.arraypf;
IF lsp↑.form = records THEN
testpacked := lsp↑.recordpf
END;
WHILE nxt <> NIL DO
WITH nxt↑ DO
BEGIN
idtype := lsp;
vaddr := lc;
lc := lc + lsize ;
IF lsp <> NIL THEN
IF lsp↑.form = files THEN
IF level > 1 THEN
error(454)
ELSE
BEGIN
IF start←channel = 0 THEN
channel := fileptr↑.fileident↑.channel
ELSE
BEGIN
channel := start←channel;
start←channel := 0
END;
IF channel < max←channel THEN
channel := channel + 1
ELSE
error(354);
new(lfileptr);
WITH lfileptr↑ DO
BEGIN
nextftp := fileptr ;
fileident := nxt
END ;
fileptr := lfileptr;
lparmptr := parmptr; found := false;
WHILE lparmptr <> NIL DO
WITH lparmptr↑ DO
BEGIN
IF fileid = name THEN
IF found THEN
error(466)
ELSE
BEGIN
fileidptr := nxt; found := true
END;
lparmptr := nextptp
END
END (*ELSE*) ;
nxt := next
END;
IF sy = semicolon THEN
BEGIN
insymbol;
iferrskip(166,fsys + [ident])
END
ELSE
error(156)
UNTIL NOT (sy IN typedels + [ident]);
WHILE forward←pointer←type <> NIL DO
BEGIN
error←with←text(405,forward←pointer←type↑.name);
forward←pointer←type := forward←pointer←type↑.next
END
END (*VARIABLEDECLARATION*) ;
PROCEDURE proceduredeclaration(procflag: boolean);
VAR
oldlev: 0..maxlevel; lcp,lcp1: ctp; lsp: stp;
forw: boolean; oldtop: disprange; lnxt: ctp;
(* LCM, (* NOT USED.*)
llc : addrrange;
PROCEDURE parameterlist(fsys:setofsys; VAR fip : ctp);
VAR
lip,lip1,lip2,lip3,lip4 : ctp; lsp : stp;
lkind : idkind; lpars:addrrange; funcdecl : boolean;
PROCEDURE ffparlist ( fsys : setofsys; VAR fip : ctp; VAR fparlc : addrrange);
VAR
lip,lip1,lip2,lip3 : ctp; lsp : stp;
lkind : idkind; lpars : addrrange; funcdecl : boolean;
BEGIN (*FFPARLIST*)
fip:=NIL;
skipiferr(fsys+[lparent],256,[]);
IF sy=lparent THEN
BEGIN
insymbol;
skipiferr([ident,varsy,proceduresy,functionsy],256,fsys+[rparent]);
IF sy IN [ident ,varsy,proceduresy,functionsy] THEN
LOOP
IF sy IN [proceduresy, functionsy] THEN
BEGIN
funcdecl:= sy=functionsy;
insymbol;
IF funcdecl THEN
new(lip,func,declared,formal)
ELSE
new(lip,proc,declared,formal);
WITH lip↑ DO
BEGIN
idtype:=NIL; next:=NIL; pflev:=level;
pfaddr:=fparlc; fparlc:=fparlc+1;
lpars:=1+ord(funcdecl);
IF funcdecl THEN
ffparlist(fsys+[rparent,colon,semicolon],lip3,lpars)
ELSE
ffparlist(fsys+[rparent,semicolon],lip3,lpars);
fparam:=lip3; parlistsize:=lpars;
END;
IF funcdecl THEN
IF sy=colon THEN
BEGIN
insymbol;
IF sy<>ident THEN
error(209)
ELSE
BEGIN
searchid([types],lip2);
lsp:=lip2↑.idtype;
IF lsp<> NIL THEN
IF NOT(lsp↑.form IN [scalar,subrange,pointer]) THEN
BEGIN
error(551);
lsp:=NIL
END;
lip↑.idtype:=lsp
END
END
ELSE
error(151)
END (*SY IN [FUNCTIONSY,PROCEDURESY]*)
ELSE
BEGIN
IF sy=varsy THEN
BEGIN
insymbol;
lkind:=formal;
IF sy=colon THEN
insymbol
ELSE
error(151)
END
ELSE
lkind:=actual;
IF sy=ident THEN
BEGIN
searchid([types],lip2);
insymbol;
lsp:=lip2↑.idtype;
IF lsp<>NIL THEN
IF lkind=actual THEN
IF lsp↑.form=files THEN
BEGIN
error(355); lsp:=NIL
END;
new(lip,vars);
WITH lip↑ DO
BEGIN
idtype:=lsp; next:=NIL; vkind:=lkind; vlev:=level;
vaddr:=fparlc;
IF lkind=formal THEN
fparlc:=fparlc+1
ELSE
IF lsp<>NIL THEN
fparlc:=fparlc+lsp↑.size;
END
END
ELSE
BEGIN
error(209); lip:=NIL
END
END;
IF lip<>NIL THEN
BEGIN
IF fip=NIL THEN
fip:=lip
ELSE
lip1↑.next:=lip;
lip1:=lip
END;
skipiferr([semicolon,ident,varsy,proceduresy,functionsy,rparent],256,fsys);
EXIT IF NOT(sy IN [semicolon,ident,varsy,proceduresy,functionsy]);
IF sy=semicolon THEN
insymbol
ELSE
error(156)
END (*LOOP*);
IF sy=rparent THEN
insymbol
ELSE
error(152);
skipiferr(fsys,166,[])
END
END (*FFPARLIST*);
BEGIN (*PARAMETERLIST*)
fip:=NIL; lip1:=NIL; lsp := NIL;
skipiferr(fsys+[lparent],256,[]);
IF sy=lparent THEN
BEGIN
IF forw THEN
error(553);
insymbol;
skipiferr([proceduresy,functionsy,varsy,ident],256,fsys+[rparent]);
IF sy IN [proceduresy,functionsy,varsy,ident] THEN
LOOP
lip2:=NIL;
IF sy IN [proceduresy,functionsy] THEN
BEGIN
funcdecl:= sy=functionsy;
insymbol;
LOOP
IF sy=ident THEN
BEGIN
IF funcdecl THEN
new(lip,func,declared,formal)
ELSE
new(lip,proc,declared,formal);
WITH lip↑ DO
BEGIN
name:=id; next:=NIL; pflev:=level;idtype:=NIL;
pfaddr:=lc; lc:=lc+1; highest←register:=parregcmax
END;
enterid(lip);
insymbol;
IF fip=NIL THEN
fip:=lip
ELSE
lip1↑.next:=lip;
lip1:=lip;
IF lip2=NIL THEN
lip2:=lip;
END
ELSE
errandskip(209,fsys+[lparent,colon,comma,ident,semicolon,rparent]);
EXIT IF NOT (sy IN [comma,ident]);
IF sy=comma THEN
insymbol
ELSE
error(158)
END (*LOOP*);
IF funcdecl THEN
BEGIN
lpars:=2;
ffparlist(fsys+[colon,semicolon,rparent],lip3,lpars);
lsp:=NIL;
IF sy=colon THEN
BEGIN
insymbol;
IF sy=ident THEN
BEGIN
searchid([types],lip4);
lsp:=lip4↑.idtype;
IF lsp<>NIL THEN
IF NOT(lsp↑.form IN [scalar,subrange,pointer]) THEN
BEGIN
error(551); lsp:=NIL
END;
insymbol
END
ELSE
errandskip(209,fsys+[colon,comma,ident])
END
ELSE
error(151);
WHILE lip2<>NIL DO WITH lip2↑ DO
BEGIN
idtype:=lsp;
fparam:=lip3; parlistsize:=lpars;
lip2:=next
END
END
ELSE
BEGIN
lpars:=1;
ffparlist(fsys+[semicolon,rparent],lip3,lpars);
WHILE lip2<>NIL DO WITH lip2↑ DO
BEGIN
fparam:=lip3;
parlistsize:=lpars;
lip2:=next
END
END
END (*SY IN [PROCEDURESY,FUNCTIONSY]*)
ELSE
BEGIN
IF sy=varsy THEN
BEGIN
lkind:=formal; insymbol
END
ELSE
lkind:=actual;
LOOP
IF sy=ident THEN
BEGIN
new(lip,vars);
WITH lip↑ DO
BEGIN
name:=id; next:=NIL; vkind:=lkind; vlev:=level;
END;
enterid(lip);
insymbol;
IF fip=NIL THEN
fip:=lip
ELSE
lip1↑.next:=lip;
lip1:=lip;
IF lip2=NIL THEN
lip2:=lip
END
ELSE
errandskip(209,fsys+[colon,comma,ident]);
EXIT IF NOT(sy IN [comma,ident]);
IF sy=comma THEN
insymbol
ELSE
error(158)
END (*LOOP*);
IF sy=colon THEN
BEGIN
insymbol;
IF sy=ident THEN
BEGIN
searchid([types],lip3);
insymbol;
lsp:=lip3↑.idtype;
IF lsp<>NIL THEN
IF (lkind=actual) AND(lsp↑.form=files) THEN
BEGIN
error(355); lsp:=NIL
END
END
ELSE
error(209)
END
ELSE
error(151);
WHILE lip2<>NIL DO WITH lip2↑ DO
BEGIN
vaddr:=lc;
IF lsp<>NIL THEN
IF vkind=formal THEN
lc:=lc+1
ELSE
lc:=lc+lsp↑.size;
idtype:=lsp;
lip2:=next
END;
END (*SY<>FUNCTIONSY*);
skipiferr([rparent,semicolon],256,[proceduresy,functionsy,ident,varsy]+fsys)
EXIT IF NOT(sy IN [semicolon,proceduresy,functionsy,varsy,ident]);
IF sy=semicolon THEN
insymbol
ELSE
error(156)
END (*LOOP*);
IF sy=rparent THEN
insymbol
ELSE
error(152);
skipiferr(fsys,166,[])
END (*SY=LPARENT*)
END (*PARAMETERLIST*);
BEGIN (*PROCEDUREDECLARATION*)
fsys:=fsys-[initprocsy];
llc := lc;
IF procflag THEN
lc := 1
ELSE
lc := 2;
IF sy = ident THEN
BEGIN
searchsection(display[top].fname,lcp); (*DECIDE WHETHER DECLARED FORWARD*)
IF lcp <> NIL THEN
(* IT SHOULD BE FORWARD *)
WITH lcp↑ DO
BEGIN
IF klass = proc THEN
IF pfkind=actual THEN
forw:=forwdecl AND procflag
ELSE
forw:=false
ELSE
IF klass = func THEN
IF pfkind=actual THEN
forw:=forwdecl AND NOT procflag
ELSE
forw:=false
ELSE
forw := false;
IF NOT forw THEN
error(558)
END
ELSE
forw := false;
IF NOT forw THEN
BEGIN
IF procflag THEN
new(lcp,proc,declared,actual)
ELSE
new(lcp,func,declared,actual);
WITH lcp↑ DO
BEGIN
name := id; idtype := NIL; testfwdptr := NIL; highest←register := parregcmax;
forwdecl := false; externdecl := false; language := pascalsy; parlistsize:=0;
pflev := level; pfaddr := 0;
FOR i := 0 TO maxlevel DO linkchain[i] := 0
END;
enterid(lcp)
END
ELSE
lc:=lcp↑.parlistsize;
insymbol
END
ELSE
(* SY <> IDENT *)
BEGIN
error(209);
IF procflag THEN
lcp := uprcptr
ELSE
lcp := ufctptr
END;
oldlev := level; oldtop := top;
IF level < maxlevel THEN
level := level + 1
ELSE
error(453);
IF top < displimit THEN
BEGIN
top := top + 1;
WITH display[top] DO
BEGIN
fname := NIL; occur := blck;
IF debug THEN
BEGIN
new(lcp1); lcp1↑ := uprcptr↑;
lcp1↑.next := lcp;
enterid(lcp1);
IF forw AND (lcp↑.next <> NIL) THEN
BEGIN
lcp1↑.llink := lcp↑.next; lcp1↑.rlink := lcp↑.next;
lcp↑.next↑.selfctp := NIL
END
END
ELSE
(* NOT DEBUG *)
IF forw THEN
fname := lcp↑.next
END (*WITH DISPLAY[TOP]*)
END
ELSE
(* TOP >= DISPLIMIT *)
error(404);
IF procflag THEN
BEGIN
parameterlist([semicolon],lcp1);
IF NOT forw THEN
WITH lcp↑ DO
BEGIN
next:=lcp1; parlistsize:=lc
END
END
ELSE
(* NOT PROCFLAG *)
BEGIN
parameterlist([semicolon,colon],lcp1);
IF NOT forw THEN
WITH lcp↑ DO
BEGIN
next := lcp1; parlistsize:=lc
END;
IF sy = colon THEN
BEGIN
insymbol;
IF sy = ident THEN
BEGIN
IF forw THEN
error(552);
searchid([types],lcp1);
lsp := lcp1↑.idtype;
lcp↑.idtype := lsp;
IF lsp <> NIL THEN
IF NOT (lsp↑.form IN [scalar,subrange,pointer]) THEN
BEGIN
error(551); lcp↑.idtype := NIL
END;
insymbol
END
ELSE
errandskip(209,fsys + [semicolon])
END
ELSE
IF NOT forw THEN
error(455)
END;
IF sy = semicolon THEN
insymbol
ELSE
error(156);
IF sy = forwardsy THEN
BEGIN
IF forw THEN
error(257)
ELSE
WITH lcp↑ DO
BEGIN
testfwdptr := forward←procedures; forward←procedures := lcp; forwdecl := true;
IF next <> NIL THEN
next↑.selfctp := uvarptr
END;
insymbol;
IF sy = semicolon THEN
insymbol
ELSE
error(156);
iferrskip(166,fsys)
END (* SY = FORWARDSY *)
ELSE
(* SY <> FORWARDSY *)
WITH lcp↑ DO
BEGIN
IF sy IN (languagesys + [externsy]) THEN
BEGIN
IF forw THEN
error(257)
ELSE
externdecl := true;
ttyread := true;
outputwrite := true; (* 13. OPEN OUTPUT ONLY IF NEEDED.*)
IF level <> 2 THEN
error(464);
IF sy IN languagesys THEN
language := sy;
insymbol;
IF (library←index = 0) OR (NOT library[language].chained) THEN
BEGIN
library←index:= library←index+1;
library←order[library←index]:= language;
library[language].chained:= true
END;
pflev := 1; pfchain := externpfptr; externpfptr := lcp;
IF sy = semicolon THEN
insymbol
ELSE
error(156);
iferrskip(166,fsys)
END (* SY = EXTERNSY *)
ELSE
(* (SY <> EXTERNSY) AND (SY <> FORWARDSY) *)
BEGIN
pfchain := localpfptr;
localpfptr := lcp;
forwdecl := false;
activated := true;
block(lcp,fsys,[beginsy,functionsy,proceduresy,period,semicolon]);
activated := false;
IF sy = semicolon THEN
BEGIN
insymbol;
skipiferr([beginsy,proceduresy,functionsy],166,fsys)
END
ELSE
error(156)
END (* SY <> EXTERNSY *)
END (* SY <> FORWARDSY *) ;
level := oldlev; top := oldtop; lc := llc
END (*PROCEDUREDECLARATION*) ;
(* BODY[ AUXILIAR PROCEDURES. *)
PROCEDURE body(fsys: setofsys);
CONST
(* FILOPN = 3B; FILBTH = 20B; (* NOT USED.*)
fileof = 1B; fileol = 2B; filsta = 11B; fildev = 12B;
filbhp = 13B; filnam = 14B; fillnr = 23B; filcmp = 25B;
VAR
last←file: ctp;
reg2←saved: boolean;
reg2←location: addrrange;
PROCEDURE generate←word(frelbyte: relbyte; flefth: addrrange; frighth: addrrange);
BEGIN (*GENERATE←WORD*)
cix := cix + 1;
IF cix > code←size THEN
BEGIN
IF NOT overrun THEN
BEGIN
overrun := true;
IF fprocp = NIL THEN
error←with←text(356,'MAIN ')
ELSE
error←with←text(356,fprocp↑.name)
END;
cix := 0
END;
WITH code←array↑.halfword[cix] DO
BEGIN
lefthalf := flefth;
righthalf := frighth
END;
code←reference↑[cix] := noinstr; code←relocation↑[cix] := frelbyte;
ic := ic + 1
END (*GENERATE←WORD*) ;
PROCEDURE insert←address(frelbyte: relbyte; fcix:coderange; fic:addrrange);
BEGIN (*INSERT←ADDRESS*)
code←array↑.instruction[fcix].address := fic;
code←relocation↑[fcix] := frelbyte
END (*INSERT←ADDRESS*);
PROCEDURE increment←regc;
BEGIN (*INCREMENT←REGC*)
regc := regc + 1 ;
IF regc > regcmax THEN
BEGIN
error(310) ; regc := regin
END
END (*INCREMENT←REGC*);
PROCEDURE deposit←constant(konsttyp:cstclass; fattr:attr);
VAR
ii:integer;
lksp,llksp: ksp;
lcsp: csp;
lref: coderefs;
newconstant,existant:boolean;
lcix: coderange;
BEGIN (*DEPOSIT←CONSTANT*)
newconstant:=true; lksp := firstkonst; (* CHECK WHETEHER THE CONSTANT EXISTS ALREADY *)
WHILE (lksp <> NIL) AND newconstant DO
WITH lksp↑,constptr↑ DO
BEGIN
IF cclass = konsttyp THEN
CASE konsttyp OF
reel:
newconstant := rval <> fattr.cval.valp↑.rval;
int:
newconstant := intval <> fattr.cval.ival;
pset:
newconstant := pval <> fattr.cval.valp↑.pval;
bptr:
newconstant := byte <> fattr.cval.byte;
strd,
strg:
IF fattr.cval.valp↑.slgth = slgth THEN
BEGIN
existant := true;
ii := 1;
REPEAT
IF fattr.cval.valp↑.sval[ii] <> sval[ii] THEN
existant := false;
ii:=ii+1
UNTIL (ii>slgth) OR NOT existant;
IF existant THEN
newconstant := false
END
END (*CASE*);
llksp := lksp; lksp := nextkonst
END (*WHILE*);
IF konsttyp = bptr THEN
lref := pointref
ELSE
lref := constref;
IF NOT newconstant (* IF IT DOES NOT EXIST YET, CREATE IT *) THEN
WITH llksp↑ DO
BEGIN
insert←address(right,cix,addr); code←reference↑[cix]:= lref;
IF konsttyp IN [pset,strd] THEN
BEGIN
insert←address(right,cix-1,addr-1); code←reference↑[cix-1]:= lref
END;
addr:= ic-1
END
ELSE
BEGIN
IF konsttyp = int THEN
BEGIN
new(lcsp,int); lcsp↑.intval := fattr.cval.ival
END
ELSE
IF konsttyp = bptr THEN
BEGIN
new(lcsp,bptr); lcsp↑.byte := fattr.cval.byte
END
ELSE
lcsp := fattr.cval.valp;
code←reference↑[cix] := lref;
IF konsttyp IN [pset,strd] THEN
code←reference↑[cix-1] := lref;
new(lksp);
WITH lksp↑ DO
BEGIN
addr := ic-1; double←chain := konsttyp IN [pset,strd];
constptr := lcsp; nextkonst := NIL
END;
IF firstkonst = NIL THEN
firstkonst := lksp
ELSE
llksp↑.nextkonst := lksp
END
END (*DEPOSIT←CONSTANT*);
PROCEDURE macro(frelbyte : relbyte;
finstr : instrange;
fac : acrange;
findbit : ibrange;
finxreg : acrange;
faddress : addrrange);
BEGIN (*MACRO*)
IF NOT initglobals THEN
BEGIN
cix := cix + 1;
IF cix > code←size THEN
BEGIN
IF NOT overrun THEN
BEGIN
overrun := true;
IF fprocp = NIL THEN
error←with←text(356,'MAIN ')
ELSE
error←with←text(356, fprocp↑.name)
END;
cix := 0
END;
WITH code←array↑.instruction[cix] DO
BEGIN
instr :=finstr;
ac :=fac;
indbit :=findbit;
inxreg :=finxreg;
address :=faddress;
code←reference↑[cix]:= noref; code←relocation↑[cix] := frelbyte
END;
ic := ic + 1
END
ELSE
error(507)
END (*MACRO*);
PROCEDURE macro5(frelbyte: relbyte; finstr : instrange; fac,finxreg : acrange; faddress : addrrange);
BEGIN
macro(frelbyte,finstr,fac,0,finxreg,faddress)
END;
PROCEDURE macro4(finstr: instrange;fac, finxreg: acrange;faddress: addrrange);
BEGIN
macro(no,finstr,fac,0,finxreg,faddress)
END;
PROCEDURE macro3(finstr : instrange; fac:acrange; faddress: addrrange);
BEGIN
macro(no,finstr,fac,0,0,faddress)
END;
PROCEDURE macro4r(finstr : instrange; fac,finxreg : acrange; faddress : addrrange);
BEGIN
macro(right,finstr,fac,0,finxreg,faddress)
END;
PROCEDURE macro3r(finstr : instrange; fac:acrange; faddress: addrrange);
BEGIN
macro(right,finstr,fac,0,0,faddress)
END;
PROCEDURE macro2(finstr: instrange; fac: acrange);
BEGIN
macro(no,finstr,fac,0,0,0)
END;
PROCEDURE put←pagenumber;
VAR
lrelbyte: relbyte;
BEGIN (*PUT←PAGENUMBER*)
lrelbyte := right;
WITH pager DO
BEGIN
lastpager := ic;
WITH word1 DO
BEGIN
IF (address = 0) OR (address = 377777B) THEN
lrelbyte := no;
macro5(lrelbyte,304B(*CAIA*),ac,inxreg,address)
END;
IF (rhalf = 0) OR (rhalf = 377777B) THEN
generate←word(no,lhalf,rhalf)
ELSE
generate←word(right,lhalf,rhalf);
lastpage := pagecnt
END
END (*PUT←PAGENUMBER*);
PROCEDURE put←linenumber;
VAR
lrelbyte: relbyte;
BEGIN (*PUT←LINENUMBER*)
lrelbyte := right;
IF pagecnt <> lastpage THEN
put←pagenumber;
IF linecnt <> lastline THEN
(*BREAKPOINT*)
BEGIN
IF linenr <> '-----' THEN
BEGIN
linecnt := 0;
FOR i := 1 TO 5 DO linecnt := 10*linecnt + ord(linenr[i]) - ord('0')
END;
linediff := linecnt - lastline;
IF (laststop = 0) OR (laststop = 377777B) THEN
lrelbyte := no;
IF linediff > 255 THEN
BEGIN
macro5(lrelbyte,334B(*SKIPA*),0,0,laststop);
laststop := ic-1;
macro3(320B(*JUMP*),0,lastline)
END
ELSE
BEGIN
macro5(lrelbyte,320B(*JUMP*),linediff MOD 16,linediff DIV 16,laststop); (*NOOP*)
laststop := ic - 1
END;
lastline := linecnt
END
END (*PUT←LINENUMBER*);
PROCEDURE support(fsupport: supports);
BEGIN (*SUPPORT*)
IF fsupport = fortranreset THEN
macro3r(265B(*JSP*),basis,runtime←support.link[fortranreset])
ELSE
IF fsupport = exitprogram THEN
macro3r(254B(*JRST*),0,runtime←support.link[exitprogram])
ELSE
macro3r(260B(*PUSHJ*),topp,runtime←support.link[fsupport]);
code←reference↑[cix]:= externref;
runtime←support.link[fsupport]:= ic-1
END (*SUPPORT*);
PROCEDURE alfaconstant( fstring: alfa);
VAR
lcsp: csp;
BEGIN (*ALFACONSTANT*)
new(lcsp,strg);
WITH lcsp↑ DO
BEGIN
slgth := 10;
FOR i := 1 TO 10 DO sval[i] := fstring[i]
END;
WITH gattr DO
BEGIN
typtr := alfaptr;
kind := cst; cval.valp := lcsp
END
END (*ALFACONSTANT*);
PROCEDURE close←files;
VAR
lfileptr: ftp;
BEGIN (*CLOSE←FILES*)
lfileptr := fileptr;
WHILE lfileptr <> NIL DO
WITH lfileptr↑, fileident↑ DO
BEGIN
macro3r(551B(*HRRZI*),regin+1,vaddr);
support(closefile);
lfileptr := nextftp
END;
END (*CLOSE←FILES*);
PROCEDURE enterbody;
VAR
i: integer; lcp : ctp;
lbtp: btp;
BEGIN (*ENTERBODY*)
lbtp := lastbtp;
WHILE lbtp <> NIL DO
BEGIN
WITH lbtp↑, arraybps[bitsize] DO
IF state = requested THEN
BEGIN
arraysp↑.arraybpaddr := ic;
address := ic; state := calculated;
ic := ic + bytemax
END
ELSE
arraysp↑.arraybpaddr := address;
lbtp := lbtp↑.last
END;
IF fprocp <> NIL THEN
BEGIN
generate←word(no,0,377777B); idtree := cix; (*IF DEBUG, INSERT TREE POINTER HERE*)
WITH fprocp↑ DO
IF pflev > 1 THEN
FOR i := maxlevel DOWNTO pflev+1 DO
macro4(540B(*HRR*),basis,basis,-1);
pfstart := ic;
IF fprocp↑.pflev = 1 THEN
macro4(512B(*HLLZM*),basis,topp,-1)
ELSE
macro4(202B(*MOVEM*),basis,topp,-1);
macro3(507B(*HRLS*),basis,topp);
macro4(307B(*CAIG*),newreg,topp,0); stacksize1 := cix;
support(stackoverflow);
macro4(541B(*HRRI*),topp,topp,0); stacksize2 := cix;
IF testpacked THEN
IF lc-lcpar <= 4 THEN
FOR i := lcpar TO lc-1 DO macro4(402B(*SETZM*),0,basis,i)
ELSE
BEGIN
macro4(551B(*HRRZI*),reg1,basis,lcpar);
macro3(505B(*HRLI*),reg1,lcpar-lc);
macro4(402B(*SETZM*),0,reg1,0);
macro3r(253B(*AOBJN*),reg1,ic-1)
END;
regc := regin+1;
lcp := fprocp↑.next;
WHILE lcp <> NIL DO
WITH lcp↑ DO
BEGIN
IF klass <> vars THEN
BEGIN
IF regc <= fprocp↑.highest←register THEN
BEGIN
macro4(202B(*MOVEM*),regc,basis,pfaddr);
increment←regc
END
END
ELSE
IF idtype <> NIL THEN
IF (vkind=formal) OR (idtype↑.size=1) THEN
(*COPY PARAMETERS FROM REGISTERS INTO LOCAL CELLS*)
BEGIN
IF regc <= fprocp↑.highest←register THEN
BEGIN
macro4(202B(*MOVEM*),regc,basis,vaddr); regc := regc + 1
END
END
ELSE
IF idtype↑.size=2 THEN
BEGIN
IF regc <= fprocp↑.highest←register THEN
BEGIN
macro4(202B(*MOVEM*),regc,basis,vaddr);
IF regc<fprocp↑.highest←register THEN
macro4(202B(*MOVEM*),regc+1,basis,vaddr+1)
END;
regc:=regc+2
END
ELSE
BEGIN
IF regc <= fprocp↑.highest←register THEN
(*COPY MULTIPLE VALUES INTO LOCAL CELLS*)
BEGIN
macro3(514B(*HRLZ*),reg1,regc); regc := regc + 1
END
ELSE
macro4(514B(*HRLZ*),reg1,basis,vaddr);
macro4(541B(*HRRI*),reg1,basis,vaddr);
macro4(251B(*BLT*),reg1,basis,vaddr+idtype↑.size-1)
END;
lcp := lcp↑.next
END
END
ELSE
(* FPROCP = NIL *)
main←start := ic;
IF (current←jump <> 0) AND (NOT external OR (level > 1)) THEN
BEGIN
jump←table[current←jump] := ic;
macro2(202B(*MOVEM*),basis); code←reference↑[cix] := saveref;
macro2(202B(*MOVEM*),topp); code←reference↑[cix] := saveref
END
END (*ENTERBODY*);
PROCEDURE leavebody;
VAR
lcp: ctp; i: integer;
lksp: ksp ; lparmptr: ptp;
ldeclscalptr: stp;
icchange: PACKED RECORD
CASE boolean OF
false:(icval: addrrange);
true :(iccsp: csp)
END;
BEGIN (*LEAVEBODY*)
IF debug THEN
put←linenumber;
IF fprocp <> NIL THEN
(* IF LEAVING THE BODY OF A PROC/FUNC*)
BEGIN
macro4(541B(*HRRI*),topp,basis,0);
macro4(547B(*HLRS*),basis,topp,-1);
macro3(263B(*POPJ*),topp,0)
END
ELSE
(* FPROCP = NIL <=> LEAVING MAIN BODY.*)
BEGIN
IF NOT external THEN
BEGIN
close←files;
IF library[fortransy].called AND fortran←enviroment THEN
BEGIN (* FORTRAN-STYLE I/O *)
macro3r(551B(*HRRZI*),regin + 1,stdfileptr[4]↑.vaddr);
support(putbuffer);
macro3(551B(*HRRZI*),basis,ic+3);
support(fortranexit);
generate←word(no,0,0);
generate←word(no,0,0)
END
ELSE
support(exitprogram);
start←address := ic;
macro3(255B(*JFCL*),0,runcore*1024); (* START-UP CODE: REPORT LOWCORE SIZE,*)
macro3(554B(*HLRZ*),basis,jbsa); (* SET THE STACK FRAME *)
macro4(505B(*HRLI*),basis,basis,0);
macro4(541B(*HRRI*),topp,basis,0); (* AND THE STACK POINTER *)
stacksize1 := cix; stacksize2 := cix;
macro3r(550B(*HRRZ*),reg1,start←address); (* CHECK FOR MEMORY SPACE CONFLICTS *)
macro3(317B(*CAMG*),reg1,jbrel);
macro3r(254B(*JRST*),0,ic+3);
macro3(047B,reg1,11B(*CORE-UUO*));
support(nocoreavailable);
macro3(200B(*MOVE*),newreg,jbrel);
macro4(307B(*CAIG*),newreg,topp,40B);
support(stackoverflow);
macro3(506B(*HRLM*),newreg,jbsa);
macro3(275B(*SUBI*),newreg,1);
macro3(505B(*HRLI*),topp,400000B);
macro3(047B,reg0,0(*RESET-UUO*));
IF library[fortransy].called AND fortran←enviroment THEN
BEGIN (* SET-UP FOR FORTRAN-STYLE I/O *)
macro4(202B(*MOVEM*),newreg,newreg,0);
macro4(202B(*MOVEM*),basis,newreg,-1);
macro4(202B(*MOVEM*),topp,newreg,-2);
support(fortranreset);
generate←word(no,0,0);
macro3(554B(*HLRZ*),reg1,jbsa);
macro4(200B(*MOVE*),newreg,reg1,-1);
macro4(200B(*MOVE*),basis,reg1,-2);
macro4(200B(*MOVE*),topp,reg1,-3)
END;
IF NOT debug AND runtime←check THEN
BEGIN
macro3(551B(*HRRZI*),reg1,110B); (*ENABLE OVERFLOW*)
macro3(047B,reg1,16B(*APRENB-UUO*))
END
END;
regc := regin + 1; lparmptr := parmptr;
IF external OR (parmptr = NIL) THEN
BEGIN
alfaconstant(programname);
name←address := ic;
macro2(551B(*HRRZI*),regc+2); deposit←constant(strg,gattr)
END;
IF NOT external THEN
BEGIN
IF parmptr <> NIL THEN
name←address := ic;
WHILE lparmptr <> NIL DO
WITH lparmptr↑ DO
BEGIN
IF fileidptr <> NIL THEN
WITH fileidptr↑ DO (* CODE TO CALL GETPARAMETER FOR THE FILE NAMES.*)
BEGIN
alfaconstant(programname);
macro2(551B(*HRRZI*),regc+2); deposit←constant(strg,gattr);
macro3r(551B(*HRRZI*),regc,vaddr);
alfaconstant(name);
macro2(551B(*HRRZI*),regc+1); deposit←constant(strg,gattr);
IF NOT inputfile THEN
macro2(400B(*SETZ*),regc+3)
ELSE
macro3(551B(*HRRZI*),regc+3,1);
support(readpgmparameter)
END
ELSE
error←with←text(264,fileid);
lparmptr := nextptp
END;
FOR i := 1 TO 4 DO macro2(400B(*SETZ*),regc+i);
IF NOT inputpar THEN
(* OPEN FILE INPUT IF NOT DECLARED AS PARAMETER *)
BEGIN
macro3r(551B(*HRRZI*),regc,stdfileptr[1]↑.vaddr);
support(resetfile);
END;
IF outputwrite AND NOT outputpar THEN
(* 13. REWRITE OUTPUT ONLY IF NEEDED.*)
BEGIN
macro3r(551B(*HRRZI*),regc,stdfileptr[2]↑.vaddr);
support(rewritefile);
END;
macro3r(551B(*HRRZI*),regc,stdfileptr[4]↑.vaddr); (* OPEN TTYOUTPUT *)
macro4(336B(*SKIPN*),0,regc,filbhp);
support(rewritefile);
IF ttyread AND resettty THEN
(* OPEN TTY, IF NEEDED.*)
BEGIN
support(opentty);
alfaconstant('TTY ');
macro2(551B(*HRRZI*),regc+1); deposit←constant(strg,gattr);
macro3r(551B(*HRRZI*),regc,stdfileptr[3]↑.vaddr);
macro4(200B(*MOVE*),regc+5,regc,fildev);
macro3(302B(*CAIE*),regc+5,tty←sixbit);
macro3(550B(*HRRZ*),regc+4,regc+1);
support(resetfile)
END;
macro3(552B(*HRRZM*),basis,debug←stackbottom + system←low←start);
macro3(332B(*SKIPE*),reg0,debug←initialization + system←low←start);
macro3(256B(*XCT*),reg0,debug←initialization + system←low←start);
macro3r(254B(*JRST*),reg0,main←start);
IF debug THEN
support(loaddebug)
END
END;
codeend := ic;
lksp:= firstkonst; (* VALUES OF THE CONSTANTS *)
WHILE lksp <> NIL DO
WITH lksp↑,constptr↑ DO
BEGIN
kaddr:= ic;
WITH icchange DO
BEGIN
icval := ic; selfcsp :=iccsp
END;
nocode := false;
CASE cclass OF
int,
bptr,
reel:
ic := ic + 1 ;
pset:
ic := ic + 2 ;
strd,
strg:
ic := ic + (slgth+4) DIV 5
END (*CASE*);
lksp := nextkonst
END (*WITH , WHILE*);
ldeclscalptr := declscalptr; (* DESCRIPTION OF THE SCALARS *)
WHILE ldeclscalptr <> NIL DO
WITH ldeclscalptr↑ DO
IF (level = tlev) OR ((level = 1) AND (tlev = 0)) THEN
BEGIN
IF request THEN
BEGIN
ic := ic+2*dimension; vectoraddr := ic; ic := ic + 2
END;
ldeclscalptr := nextscalar
END
ELSE
ldeclscalptr := NIL;
IF debug←switch THEN
BEGIN
lcp := display[top].fname;
IF (level > 1) AND ( lcp <> NIL ) THEN
BEGIN
IF lcp↑.selfctp = NIL THEN
i:= ic
ELSE
i := ord(lcp↑.selfctp);
insert←address(right,idtree,i)
END
END;
IF level = 1 THEN
highest←code := ic
END(*LEAVEBODY*);
PROCEDURE fetch←basis(VAR fattr: attr); (* CODE TO PUT IN INDEXR THE BASIS OF A SUBSTRUCTURE *)
VAR
p,q: integer;
BEGIN (*FETCH←BASIS*)
WITH fattr DO
IF vlevel>1 THEN
BEGIN
p := level - vlevel;
IF p=0 THEN
IF indexr=0 THEN
indexr := basis
ELSE
macro3(270B(*ADD*),indexr,basis)
ELSE
BEGIN
macro4(550B(*HRRZ*),reg1,basis,-1);
FOR q := p DOWNTO 2 DO
macro4(550B(*HRRZ*),reg1,reg1,-1);
IF indexr=0 THEN
indexr := reg1
ELSE
macro4(271B(*ADDI*),indexr,reg1,0)
END;
(*WITHIN A WITH-STATEMENT, THERE IS THE POSSIBILITY THAT
FETCH←BASIS WILL BE ACTIVATED TWO TIMES*)
vlevel := 1
END
END (*FETCH←BASIS*);
PROCEDURE get←parameter←address; (*CODE TO LOAD THE ADDRESS OF A FORMAL PARAMETER*)
BEGIN (*GET←PARAMETER←ADDRESS*)
fetch←basis(gattr);
WITH gattr DO
BEGIN
increment←regc;
macro5(vrelbyte,200B(*MOVE*),regc,indexr,dplmt);
indexr := regc; vrelbyte:= no;
indbit := 0; vlevel := 1; dplmt := 0
END
END (*GET←PARAMETER←ADDRESS*);
PROCEDURE generate←code(finstr: instrange; fac: acrange; VAR fattr: attr);
VAR
linstr: instrange;
lregc: acrange;
lattr: attr;
lrelbyte: relbyte;
labs: integer;
BEGIN (*GENERATE←CODE*)
lrelbyte := right;
WITH fattr DO
IF typtr<>NIL THEN
BEGIN
CASE kind OF
cst:
IF typtr=realptr THEN
BEGIN
macro3(finstr,fac,0); deposit←constant(reel,fattr)
END
ELSE
IF typtr↑.form=scalar THEN
WITH cval DO
BEGIN
IF ival = -maxint - 1 THEN
labs := maxint
ELSE
labs := abs(ival);
IF ((ival >= 0) AND (ival <= maxaddr))
OR
((labs <= hwcstmax+1) AND (finstr = 200B(*MOVE*))) THEN
BEGIN
IF finstr=200B(*MOVE*) THEN
IF ival < 0 THEN
finstr := 561B(*HRROI*)
ELSE
finstr := 551B(*HRRZI*)
ELSE
IF (finstr>=311B) AND (finstr <= 317B) THEN
finstr := finstr - 10B (*E.G. CAML --> CAIL*)
ELSE
finstr := finstr+1;
macro3(finstr,fac,ival)
END
ELSE
BEGIN
macro3(finstr,fac,0); deposit←constant(int,fattr)
END
END
ELSE
IF typtr=nilptr THEN
BEGIN
IF finstr=200B(*MOVE*) THEN
finstr := 551B(*HRRZI*)
ELSE
IF (finstr>=311B) AND (finstr<=317B) THEN
finstr := finstr-10B
ELSE
finstr := finstr+1;
macro3(finstr,fac,377777B)
END
ELSE
IF typtr↑.form=power THEN
BEGIN
macro3(finstr,fac,0); macro3(finstr,fac-1,0); deposit←constant(pset,fattr)
END
ELSE
IF typtr↑.form=arrays THEN
IF typtr↑.size = 1 THEN
BEGIN
macro3(finstr,fac,0); deposit←constant(strg,fattr)
END
ELSE
IF typtr↑.size = 2 THEN
BEGIN
fattr.cval.valp↑.cclass := strd;
macro3(finstr,fac,0); macro3(finstr,fac-1,0); deposit←constant(strd,fattr)
END;
varbl:
BEGIN
fetch←basis(fattr); lregc := fac;
IF (indexr>regin) AND (indexr<=regcmax) AND ((packfg<>notpack) OR (finstr=200B(*MOVE*))) THEN
IF (typtr↑.size = 2) AND loadnoptr THEN
lregc := indexr+1
ELSE
lregc := indexr
ELSE
IF (packfg<>notpack) AND (finstr<>200B(*MOVE*)) THEN
BEGIN
increment←regc; lregc := regc
END;
CASE packfg OF
notpack:
BEGIN
IF (typtr↑.size = 2) AND loadnoptr THEN
BEGIN
macro5(vrelbyte,finstr,lregc,indexr,dplmt+1);
macro5(vrelbyte,finstr,lregc-1,indexr,dplmt)
END
ELSE
macro(vrelbyte,finstr,lregc,indbit,indexr,dplmt)
END;
packk:
BEGIN
IF vclass = field THEN
BEGIN
WITH lattr, cval, byte DO
BEGIN
kind := cst;
cval.byte := fattr.vbyte;
ibit := ord(fattr.vrelbyte);
ireg := fattr.indexr;
reladdr := reladdr + fattr.dplmt
END;
macro2(135B(*LDB*),lregc); deposit←constant(bptr,lattr)
END
ELSE
BEGIN
macro5(vrelbyte,551B(*HRRZI*),reg1,indexr,dplmt);
IF (bpaddr>regin) AND (bpaddr<=regcmax) THEN
IF (indexr<=regin) OR (bpaddr<indexr) THEN
lregc := bpaddr
ELSE
lregc := indexr;
IF bpaddr < high←start THEN
lrelbyte := no;
macro5(lrelbyte,135B(*LDB*),lregc,0,bpaddr)
END
END;
hwordl:
macro5(vrelbyte,554B(*HLRZ*),lregc,indexr,dplmt);
hwordr:
macro5(vrelbyte,550B(*HRRZ*),lregc,indexr,dplmt)
END (*CASE*);
IF (finstr<>200B(*MOVE*)) AND (packfg<>notpack) THEN
macro3(finstr,fac,lregc)
ELSE
fac := lregc
END;
expr:
IF finstr <> 200B(*MOVE*) THEN
BEGIN
macro3(finstr,fac,reg);
IF typtr↑.size = 2 THEN
macro3(finstr,fac-1,reg-1)
END
END (*CASE*);
kind := expr; reg := fac
END
END (*GENERATE←CODE*);
PROCEDURE load(VAR fattr: attr); (*CODE TO PUT THE VALUE OF FATTR IN A REGISTER*)
VAR
linstr: instrange;
BEGIN (*LOAD*)
WITH fattr DO
IF typtr<>NIL THEN
IF kind<>expr THEN
BEGIN
increment←regc ; linstr := 200B(*MOVE*);
IF (typtr↑.size = 2) AND loadnoptr THEN
increment←regc ;
generate←code(linstr,regc,fattr); regc := reg
END
END (*LOAD*) ;
PROCEDURE store(fac: acrange; VAR fattr: attr); (*CODE TO STORE IN MEMORY THE VALUE IN FAC*)
VAR
lattr: attr; lattrc: attr; lrelbyte: relbyte;
BEGIN (*STORE*)
lattr := fattr; lrelbyte := right;
WITH lattr DO
IF typtr <> NIL THEN
BEGIN
fetch←basis(lattr);
CASE packfg OF
notpack:
BEGIN
IF typtr↑.size = 2 THEN
BEGIN
macro5(vrelbyte,202B(*MOVEM*),fac,indexr,dplmt+1); fac := fac-1
END;
macro(vrelbyte,202B(*MOVEM*),fac,indbit,indexr,dplmt)
END;
packk:
IF vclass = field THEN
BEGIN
WITH lattrc, cval, byte DO
BEGIN
kind := cst;
cval.byte := lattr.vbyte;
ibit := ord(lattr.vrelbyte);
ireg := lattr.indexr;
reladdr := reladdr + lattr.dplmt
END;
macro2(137B(*DPB*),fac); deposit←constant(bptr,lattrc)
END
ELSE
BEGIN
macro5(vrelbyte,551B(*HRRZI*),reg1,indexr,dplmt);
IF bpaddr < high←start THEN
lrelbyte := no;
macro5(lrelbyte,137B(*DPB*),fac,0,bpaddr)
END;
hwordl:
macro5(vrelbyte,506B(*HRLM*),fac,indexr,dplmt);
hwordr:
macro5(vrelbyte,542B(*HRRM*),fac,indexr,dplmt)
END (*CASE*)
END (*WITH*)
END (*STORE*) ;
PROCEDURE load←address; (*CODE TO PUT THE ADDRESS OF GATTR IN A REGISTER*)
BEGIN (*LOAD←ADDRESS*)
increment←regc ;
BEGIN
WITH gattr DO
IF typtr <> NIL THEN
BEGIN
CASE kind OF
cst:
IF string(typtr) THEN
BEGIN
macro3(551B(*HRRZI*),regc,0);
deposit←constant(strg,gattr)
END
ELSE
error(171);
varbl:
BEGIN
IF (indexr>regin) AND (indexr <= regcmax) THEN
regc := indexr;
fetch←basis(gattr);
CASE packfg OF
notpack:
macro(vrelbyte,551B(*HRRZI*),regc,indbit,indexr,dplmt);
packk,hwordl,hwordr:
error(357)
END;
IF typtr↑.form = files THEN
IF last←file <> NIL THEN
WITH last←file↑ DO
IF (vlev = 0) AND external THEN
BEGIN
vaddr := ic-1; code←reference↑[cix] := externref
END
END;
expr:
error(171)
END;
kind := varbl; dplmt := 0; indexr:=regc; indbit:=0; vrelbyte := no; vclass := vars
END
END
END (*LOAD←ADDRESS*) ;
(* WRITE←MACHINE←CODE[ AND ITS PARTS. *)
PROCEDURE write←machine←code(write←flag:write←form);
TYPE
bigalfa = PACKED ARRAY[1..20] OF char ;
VAR
llist←code, put←code←array: boolean;
lic, licmod4: addrrange;
space←c, space←w: integer;
PROCEDURE new←line;
BEGIN (*NEW←LINE*)
licmod4 := lic MOD 4;
IF (licmod4 = 0) AND list←code AND (lic > 0) THEN
BEGIN
writeln(list);
WITH relocation←block DO
BEGIN
IF item = item←1 THEN
write(list, lic:6:o, showrelo[relocator[0] = right])
ELSE
write(list,' ':7)
END
END
END (*NEW←LINE*) ;
PROCEDURE put←relocatable←code;
VAR
i: integer;
BEGIN (*PUT←RELOCATABLE←CODE*)
WITH relocation←block DO
BEGIN
IF ((count > 1) OR (item <> item←1)) AND (count > 0) THEN
BEGIN
FOR i:= count+1 TO 18 DO relocator[i-1] := no;
FOR i:= 1 TO count+2 DO
BEGIN
object↑:= component[i];
put(object)
END
END;
count := 0
END
END (*PUT←RELOCATABLE←CODE*);
PROCEDURE write←block←start(frelbyte: relbyte; flic: addrrange; fitem: addrrange);
VAR
change: PACKED RECORD
CASE boolean OF
true: (wkonst: integer);
false:(wlefthalf: addrrange; wrighthalf: addrrange)
END;
BEGIN (*WRITE←BLOCK←START*)
WITH relocation←block , change DO
BEGIN
IF count <> 0 THEN
put←relocatable←code;
item := fitem;
lic := flic;
IF item = item←1 THEN
BEGIN
wlefthalf:= 0;
wrighthalf:= lic;
code[0]:= wkonst;
relocator[0] := frelbyte;
count:= 1
END
END
END (*WRITE←BLOCK←START*);
(* 18. PASCAL VERSION OF WRITE←WORD.*)
PROCEDURE write←word(frelbyte: relbyte; fword: integer);
VAR
change: PACKED RECORD
CASE boolean OF
true: (wkonst: integer);
false:(wlefthalf: addrrange; wrighthalf: addrrange)
END;
BEGIN (*WRITE←WORD*)
WITH change DO
BEGIN
wkonst := fword;
WITH relocation←block DO
BEGIN
IF count = 0 THEN
write←block←start(relocator[0],lic,item);
code[count]:= fword;
IF NOT put←code←array THEN
BEGIN
IF frelbyte IN [left,both] THEN
IF (wlefthalf = 0) OR (wlefthalf = 377777B) THEN
IF frelbyte = both THEN
frelbyte := right
ELSE
frelbyte := no;
IF frelbyte IN [right,both] THEN
IF (wrighthalf = 0) OR (wrighthalf = 377777B) THEN
IF frelbyte = both THEN
frelbyte := left
ELSE
frelbyte := no
END;
relocator[count]:= frelbyte;
count := count+1;
IF count = 18 THEN
put←relocatable←code
END;
IF llist←code THEN
BEGIN
new←line;
IF lic > 0 THEN
IF licmod4 = 0 THEN
write(list,' ':13)
ELSE
write(list,' ':11,' ':space←w);
IF write←flag > write←fileblocks THEN
write(list,' ':7)
ELSE
write(list,wlefthalf:6:o, showrelo[ frelbyte IN [left,both] ] );
write(list,wrighthalf:6:o, showrelo[ frelbyte IN [right,both] ], ' ':3)
END;
lic := lic + 1;
space←w := 2
END
END (*WRITE←WORD*);
FUNCTION radix50( fname: alfa): radixrange;
VAR
i: integer; c: char; octalcode, radixvalue: radixrange;
BEGIN (*RADIX50*)
radixvalue:= 0;
i:=1; c := fname[1];
WHILE (c <> ' ') AND (i <= 6) DO
BEGIN
IF c IN digits THEN
octalcode:= ord(c)-ord('0')+1
ELSE
IF c IN letters THEN
octalcode:= ord(c)-ord('A')+11
ELSE
IF c = '.' THEN
octalcode:= 37
ELSE
IF c = '$' THEN
octalcode:= 38
ELSE
IF c = '%' THEN
octalcode:= 39;
radixvalue:= radixvalue*50B+octalcode; i:=i+1; c := fname[i]
END;
radix50:= radixvalue
END (*RADIX50*);
PROCEDURE write←pair( frelbyte: relbyte; faddr1, faddr2: addrrange);
BEGIN (*WRITE←PAIR*)
WITH change DO
BEGIN
wlefthalf:= faddr1;
wrighthalf:= faddr2;
write←word( frelbyte, wkonst)
END
END (*WRITE←PAIR*);
PROCEDURE write←identifier( fflag: flagrange; fsymbol: alfa);
BEGIN (*WRITE←IDENTIFIER*)
llist←code := false;
WITH change DO
BEGIN
IF list←code AND (write←flag > write←hiseg) THEN
BEGIN
IF lic > 0 THEN
BEGIN
IF lic MOD 4 = 0 THEN
BEGIN
writeln(list); write(list,' ':7)
END;
write(list,' ':13)
END;
write(list,fsymbol:6,' ':11)
END;
IF fflag <> sixbit←symbol THEN
BEGIN
flag:= fflag; symbol:= radix50(fsymbol)
END;
write←word(no,wkonst);
llist←code := list←code
END
END (*WRITE←IDENTIFIER*);
PROCEDURE write←first←line ;
BEGIN (*WRITE←FIRST←LINE*)
IF list←code THEN
BEGIN
writeln(list);
licmod4 := lic MOD 4;
IF licmod4 > 0 THEN
write(list,(lic-licmod4):6:o,showrelo[relocation←block.relocator[0] = right],' ':licmod4*30)
END
END (*WRITE←FIRST←LINE*);
PROCEDURE write←header(ftext: bigalfa);
BEGIN (*WRITE←HEADER*)
IF list←code THEN
BEGIN
writeln(list); writeln(list); write(list,ftext:16,':',' ':3); lic := 0
END
END (*WRITE←HEADER*);
PROCEDURE write←constant(fcst: cstclass);
VAR
i, j: integer; lrelbyte: relbyte;
BEGIN (*WRITE←CONSTANT*)
WITH change DO
BEGIN
IF (fcst = bptr) AND (wbyte.ibit <> 0) THEN
BEGIN
wbyte.ibit := 0; lrelbyte := right
END
ELSE
lrelbyte := no;
IF list←code THEN
BEGIN
new←line;
IF licmod4 = 0 THEN
write(list,' ':8)
ELSE
write(list,' ':6,' ':space←c);
CASE fcst OF
int:
write(list,'[',' ':10,wkonst,']');
reel:
write(list,'[',' ':5,wreal,']');
strd,
strg:
BEGIN
write(list,'[',' ':15,''''); j := 0;
FOR i := 1 TO 5 DO
IF NOT (wstring[i] IN [' '..'←']) THEN
j := j + 1
ELSE
write(list,wstring[i]);
write(list,'''',' ':j,']')
END;
pset:
write(list,'[',' ':10,wkonst:12:o,']');
bptr:
WITH wbyte DO
write(list, 'POINT ', sbits:2, ', ',
reladdr:5:o, showrelo[(lrelbyte = right)], '(',
ireg:2:o, '),', 35-pbits:2)
END
END;
write←word(lrelbyte,wkonst);
space←c := 0
END
END (*WRITE←CONSTANT*);
PROCEDURE code←for←fileblocks;
VAR
stopptr, lfileptr: ftp;
i: integer;
filblockadr: addrrange;
(* IMPLEMENTATION OF FILES IN DECSYSTEM-10 PASCAL
FILE TYPE PACKED UNPACKED
------------------------------------------------
(SUBRANGE OF) ASCII-MODE, BINARY-MODE,
CHAR FORMATTED I/O, STANDARD I/O,
"UPPER CASE", "FULL BOARD"
LINENUMBERS &
PAGEMARKS
(SUBRANGE OF) ASCII-MODE, AS ABOVE
ASCII STANDARD I/O,
. "FULL BOARD"
OTHER TREATED AS ABOVE
. AS UNPACKED
*)
BEGIN (*CODE←FOR←FILEBLOCKS*)
lfileptr:= fileptr;
IF NOT external THEN
stopptr := NIL
ELSE
stopptr := sfileptr;
WHILE lfileptr <> stopptr DO
WITH lfileptr↑, fileident↑, change DO
IF idtype=NIL THEN
BEGIN
error(171); lfileptr:=stopptr
END
ELSE
BEGIN
filblockadr := vaddr;
write←block←start(right,filblockadr,item←1);
write←first←line;
wlefthalf := idtype↑.file←form;
wrighthalf := filblockadr + filcmp;
write←word(right,wkonst);
write←word(no,0) ; write←word(no,0) ; (*RESERVE LOCATIONS FOR FILEOF AND FILEOL*)
wkonst := 0;
winstr.instr := 50B (*OPEN*) ; winstr.ac := channel ;
winstr.address := filblockadr + filsta ;
write←word(right,wkonst) (*FILOPN*) ;
winstr.instr := 76B (*LOOKUP*) ; winstr.address := filblockadr + filnam ;
write←word(right,wkonst);
winstr.instr := 77B (*ENTER*) ;
write←word(right,wkonst);
winstr.address := 0 ;
winstr.instr := 56B (* IN*) ; write←word(no,wkonst);
winstr.instr := 57B (*OUT*) ; write←word(no,wkonst) ;
winstr.instr := 70B (*CLOSE*) ; write←word(no,wkonst);
write←word(no,idtype↑.file←mode);
IF (name = 'TTYOUTPUT ') OR (name = 'TTY ') THEN
wlefthalf := tty←sixbit
ELSE
wlefthalf := dsk←sixbit;
wrighthalf := 0;
write←word(no,wkonst);
write←word(no,0); (*BUFFERHEADER ADDRESS INSERTED DURING RESET OR REWRITE*)
FOR i := 1 TO 6 DO wsixbit[i] := ord( name[i] ) - 40B ;
write←word(no,wkonst);
wkonst := 0 ;
FOR i := 1 TO 3 DO wsixbit[i] := ord( name[i+6] ) - 40B ;
write←word(no,wkonst);
FOR i := 1 TO 6 DO write←word(no,0 ) (*ZERO IN FILPROT, FILPPN, FILBFH, FILBTP, FILBTC,FILLNR*);
(* 18.*)
wlefthalf := - idtype↑.filtype↑.size ; wrighthalf := filblockadr + filcmp ;
write←word(right,wkonst) (*FILCNT*) ;
FOR i := 1 TO idtype↑.filtype↑.size DO write←word(no,0 ) (*CLEAR COMPONENT LOCATIONS *) ;
(* 18.*)
lfileptr := nextftp;
END;
END (*CODE←FOR←FILEBLOCKS*);
PROCEDURE code←for←instructions;
VAR
i, j, nn: integer;
lbyte: bpointer; ldeclscalptr: stp; lfconst: ctp;
lrelbyte: relbyte; lfirstkonst: ksp; lreference: coderefs;
string: ARRAY[1..6] OF char;
BEGIN (*CODE←FOR←INSTRUCTIONS*)
llist←code:= false;
IF list←code THEN
writebuffer;
IF lastbtp <> NIL THEN
(* WRITE THE BYTEPOINTERS *)
BEGIN
write←block←start(right,lastbtp↑.arraysp↑.arraybpaddr,item←1);
write←first←line;
WHILE lastbtp <> NIL DO
BEGIN
WITH lastbtp↑, arraybps[bitsize] DO
BEGIN
lbyte := abyte;
IF state = calculated THEN
BEGIN
nn := bytemax; state:= used
END
ELSE
nn:=0
END;
FOR i:=1 TO nn DO
BEGIN
WITH change DO
BEGIN
wbyte := lbyte; write←constant(bptr)
END;
WITH lbyte DO pbits := pbits - sbits
END (*FOR*);
lastbtp := lastbtp↑.last
END (* WHILE*)
END (*LASTBTP<>NIL*) ;
put←code←array := true; (* WRITE THE INSTRUCTION CODE *)
write←block←start(right,codeend-cix-1,item←1);
write←first←line;
IF list←code AND (licmod4 <> 0) THEN
write(list,' ':2);
FOR i := 0 TO cix DO
WITH code←array↑, instruction[i] DO
BEGIN
lrelbyte := code←relocation↑[i];
lreference := code←reference↑[i];
IF (lreference IN [externref,constref,forwardref,gotoref,pointref,saveref,debugref])
AND (address = 0) THEN
lrelbyte := no;
IF list←code THEN
BEGIN
new←line;
IF licmod4 = 0 THEN
write(list,' ':8)
ELSE
write(list,' ':6);
CASE lreference OF
noinstr:
WITH halfword[i] DO
write(list,' ':5,lefthalf :6:o, showrelo[lrelbyte IN [left,both]],
righthalf:6:o, showrelo[lrelbyte IN [right,both]],' ':5);
OTHERS:
BEGIN
unpack(mnemonics[(instr+9) DIV 10],string,1,((instr+9) MOD 10)*6+1,6);
write(list,string:6, ' ',ac:2:o,', ', showibit[indbit],
address:6:o, showrelo[lrelbyte IN [right,both]]);
IF inxreg > 0 THEN
write(list,'(',inxreg:2:o,')',showref[lreference])
ELSE
write(list,' ':4,showref[lreference])
END
END (*CASE*)
END;
write←word(lrelbyte,word[i])
END (*FOR *) ;
put←code←array := false;
IF (firstkonst <> NIL) OR (declscalptr <> NIL) THEN
BEGIN (* WRITE THE VALUES OF THE CONSTANTS *)
lfirstkonst := firstkonst;
write←block←start(right,lic,item←1);
write←first←line;
IF list←code AND (licmod4 <> 0) THEN
write(list,' ':2);
WHILE lfirstkonst <> NIL DO
BEGIN
WITH lfirstkonst↑.constptr↑, change DO
BEGIN
CASE cclass OF
int,
reel:
wkonst := intval;
pset:
BEGIN
wkonst := intval; write←constant(cclass);
wkonst := intval1
END;
bptr:
wbyte := byte;
strd,
strg:
BEGIN
j :=0; wkonst := 0;
FOR i := 1 TO slgth DO
BEGIN
j := j+1;
wstring[j] := sval[i];
IF j=5 THEN
BEGIN
j := 0;
write←constant(cclass);
wkonst := 0
END
END
END
END;
IF NOT (cclass IN [strd,strg]) OR (j <> 0) THEN
write←constant(cclass)
END;
lfirstkonst := lfirstkonst↑.nextkonst
END (*WHILE*) ;
ldeclscalptr := declscalptr; (* WRITE THE DESCRIPTIONS OF SCALARS *)
WHILE ldeclscalptr <> NIL DO
WITH ldeclscalptr↑ DO
IF (level = tlev) OR ((level = 1) AND (tlev = 0)) THEN
BEGIN
IF request THEN
BEGIN
lfconst := fconst;
WHILE lfconst <> NIL DO
WITH lfconst↑ DO
BEGIN
FOR j := 0 TO 1 DO
WITH change DO
BEGIN
wkonst := 0;
FOR i := 1 TO 5 DO
wstring[i] := name[i+j*5];
write←constant(strd)
END;
lfconst := next
END
END;
ldeclscalptr := nextscalar
END
ELSE
ldeclscalptr := NIL
END;
IF level = 1 THEN
BEGIN
jump←address := lcmain;
lcmain := lcmain + 2 * jumper
END;
IF NOT debug AND (level = 1) THEN
BEGIN
llist←code := list←code;
IF list←code THEN
BEGIN
writeln(list); write(list,debug←save:6:o,'''',' ':13)
END;
write←block←start(right,debug←save,item←1);
FOR i := debug←save TO debug←programname DO
write←word(no,0)
END
END (*CODE←FOR←INSTRUCTIONS*);
PROCEDURE code←for←globals;
VAR
i, j: integer;
BEGIN (*CODE←FOR←GLOBALS*)
IF list←code AND (fglobptr <> NIL) THEN
writebuffer;
WHILE fglobptr <> NIL DO
WITH fglobptr↑ DO
BEGIN
j := fcix ;
write←block←start(right,firstglob,item←1);
write←first←line;
FOR i := firstglob TO lastglob DO
BEGIN
change.winstr := code←array↑.instruction[j] ; j := j + 1 ;
write←word(no,change.wkonst)
END ;
fglobptr := nextglobptr
END
END (*CODE←FOR←GLOBALS*);
PROCEDURE code←for←debug;
CONST
maxsize (*OF CONSTANT-, STRUCTURE-, AND IDENTIFIER-RECORD*) = 24 (*WORDS*) ;
TYPE
recordform = (unspecific, const←rec, struct←rec,
ident←rec, debug←rec);
VAR
lnlk : nlk;
lcp: ctp;
lsize: 1..maxsize; run1: boolean;
relarray, relempty: ARRAY[1..maxsize] OF relbyte;
icchange: PACKED RECORD
CASE integer OF
1:(icval: addrrange);
2:(iccsp: csp);
3:(icctp: ctp);
4:(icstp: stp)
END;
recordchange: PACKED RECORD
CASE recordform OF
unspecific: (word:ARRAY[1..maxsize] OF integer);
const←rec: (string1: PACKED ARRAY[1..strglgth] OF char);
struct←rec: (structrec: structure);
ident←rec: (identrec: identifier);
debug←rec: (debugrec: debentry)
END;
PROCEDURE write←record(record←form: recordform);
VAR
i, j: integer;
BEGIN (*WRITE←RECORD*)
llist←code := false;
space←c := 2;
CASE record←form OF
ident←rec :
j := 2;
const←rec :
j := lsize;
OTHERS :
j := 0;
END;
IF j <> 0 THEN
BEGIN
FOR i := 1 TO j DO
BEGIN
change.wkonst := recordchange.word[i];
write←constant(strg)
END;
space←w := 0
END;
llist←code := list←code;
FOR i := j + 1 TO lsize DO write←word(relarray[i],recordchange.word[i] )
END (*WRITE←RECORD*);
PROCEDURE copycsp(fcsp:csp);
BEGIN (*COPYCSP*)
IF fcsp <> NIL THEN
WITH fcsp↑ DO
BEGIN
IF cclass IN [strg,strd] THEN
lsize := (slgth + 4) DIV 5
ELSE
error(171);
IF run1 THEN
BEGIN
IF selfcsp = NIL THEN
WITH icchange DO
BEGIN
icval := ic; selfcsp := iccsp;
nocode := true;
ic := ic + lsize
END
END
ELSE
IF nocode THEN
BEGIN
recordchange.string1 := fcsp↑.sval;
relarray := relempty;
write←record(const←rec); nocode := false
END
END (*WITH FCSP↑*)
END (*COPYCSP*);
PROCEDURE copystp(fsp:stp);
FORWARD;
PROCEDURE copyctp(fcp:ctp);
BEGIN (*COPYCTP*)
IF fcp <> NIL THEN
WITH fcp↑ DO
IF run1 AND (selfctp=NIL) OR NOT run1 AND nocode THEN
BEGIN
lsize := idrecsize[klass];
IF run1 THEN
WITH icchange DO
BEGIN
icval := ic;
selfctp := icctp; nocode := true;
ic := ic + lsize
END (* RUN1 *)
ELSE
WITH recordchange DO
BEGIN
relarray := relempty;
identrec := fcp↑;
WITH identrec DO
BEGIN
IF llink<>NIL THEN
llink:=llink↑.selfctp;
IF rlink<>NIL THEN
rlink:=rlink↑.selfctp;
relarray[3] := both;
IF next <>NIL THEN
next := next↑.selfctp;
relarray[4] := both;
IF idtype <> NIL THEN
BEGIN
CASE klass OF
konst:
IF idtype↑.form > pointer THEN
BEGIN
values.valp := values.valp↑.selfcsp;
relarray[6] := right
END
ELSE
IF idtype = realptr THEN
BEGIN
change.wreal := values.valp↑.rval;
values.ival := change.wkonst
END;
vars:
BEGIN
IF vlev < 2 THEN
relarray[6] := right;
WITH fcp↑ DO
IF (idtype↑.form = files) AND (vlev = 0) AND external THEN
vaddr := ord(selfctp) + 5
END
END (*CASE*);
idtype := idtype↑.selfstp
END
END;
write←record(ident←rec); nocode := false
END (* RUN2 *);
copyctp(llink);
copyctp(rlink);
copystp(idtype);
copyctp(next);
IF (klass = konst) AND (idtype <> NIL) THEN
IF idtype↑.form > pointer THEN
copycsp(values.valp)
END (*WITH FCP↑*)
END (*COPYCTP*);
PROCEDURE copystp;
BEGIN (*COPYSTP*)
IF fsp <> NIL THEN
WITH fsp↑ DO
BEGIN
IF run1 AND (selfstp = NIL) OR NOT run1 AND nocode THEN
BEGIN
lsize := strecsize[form];
IF run1 THEN
WITH icchange DO
BEGIN
nocode:=true;
icval := ic; selfstp := icstp;
ic := ic + lsize
END (* RUN1 *)
ELSE
WITH recordchange DO
BEGIN
relarray := relempty; relarray[2] := right;
structrec := fsp↑;
WITH structrec DO
CASE form OF
scalar:
IF scalkind = declared THEN
IF fconst<>NIL THEN
fconst:=fconst↑.selfctp;
subrange:
rangetype:=rangetype↑.selfstp;
pointer:
IF eltype <> NIL THEN
eltype := eltype↑.selfstp;
power:
elset := elset↑.selfstp;
arrays:
BEGIN
aeltype := aeltype↑.selfstp;
inxtype := inxtype↑.selfstp; relarray[3] := both
END;
records:
BEGIN
IF fstfld <> NIL THEN
fstfld := fstfld↑.selfctp;
IF recvar <> NIL THEN
BEGIN
recvar := recvar↑.selfstp; relarray[3] := left
END
END;
files:
filtype := filtype↑.selfstp;
tagfwithid,
tagfwithoutid:
BEGIN
fstvar := fstvar↑.selfstp;
IF form = tagfwithid THEN
tagfieldp := tagfieldp↑.selfctp;
relarray[3] := left
END;
variant:
BEGIN
IF subvar <> NIL THEN
subvar := subvar↑.selfstp;
IF firstfield <> NIL THEN
firstfield := firstfield↑.selfctp;
relarray[3] := both;
IF nxtvar <> NIL THEN
nxtvar := nxtvar↑.selfstp
END
END (*CASE*);
write←record(struct←rec); nocode := false
END (*RUN 2*);
CASE form OF
scalar:
IF scalkind = declared THEN
copyctp(fconst);
subrange:
copystp(rangetype);
pointer:
copystp(eltype);
power:
copystp(elset);
arrays:
BEGIN
copystp(aeltype);
copystp(inxtype)
END;
records:
BEGIN
copyctp(fstfld);
copystp(recvar)
END;
files:
copystp(filtype);
tagfwithid,
tagfwithoutid:
BEGIN
copystp(fstvar);
IF form = tagfwithid THEN
copyctp(tagfieldp)
END;
variant:
BEGIN
copystp(nxtvar);
copystp(subvar);
copyctp(firstfield)
END
END (*CASE*)
END ;
END (* WITH FSP↑ *)
END (*COPYSTP*);
BEGIN (*CODE←FOR←DEBUG*)
FOR i := 1 TO maxsize DO relempty[i] := no;
IF debug←switch THEN
BEGIN
write←first←line;
lcp := display[top].fname;
IF level = 1 THEN
BEGIN
debugentry.globalidtree := ic;
IF lcp<>NIL THEN
IF lcp↑.selfctp <> NIL THEN
debugentry.globalidtree := ord(lcp↑.selfctp)
END;
FOR run1 := true DOWNTO false DO copyctp(lcp);
lnlk := globnewlink;
WHILE lnlk <> NIL DO
WITH lnlk↑ DO
BEGIN
IF reftype↑.selfstp = NIL THEN
FOR run1 := true DOWNTO false DO copystp(reftype);
lnlk := next
END;
IF level = 1 THEN
BEGIN
debugentry.standardidtree := ic;
FOR run1 := true DOWNTO false DO copyctp(display[0].fname)
END;
END (*DEBUG←SWITCH*);
IF level = 1 THEN
BEGIN
WITH debugentry DO
BEGIN
newpager; lastpageelem := pager;
intpoint := intptr↑. selfstp;
realpoint := realptr↑.selfstp;
boolpoint := boolptr↑.selfstp;
charpoint := asciiptr↑.selfstp
END;
pageheadadr := ic;
FOR i:=1 TO debentry←size DO relarray[i] := right;
recordchange.debugrec := debugentry;
ic := ic + debentry←size;
lsize := debentry←size;
write←record(debug←rec);
highest←code := ic;
IF list←code THEN
BEGIN
writeln(list); write(list,debug←save:6:o,'''',' ':13)
END;
write←block←start(right, debug←save,item←1);
write←word(no,0);
write←pair(no,260740B(*PUSHJ 17,*),0);
write←pair(right,0,pageheadadr);
FOR i := 1 TO 3 DO write←word(no,0);
write←pair(no,260740B(*PUSHJ, 17*),0);
write←pair(right,0,name←address)
END (*LEVEL=1*)
END (*CODE←FOR←DEBUG*);
(* PARTS. ]WRITE←MACHINE←CODE. *)
PROCEDURE code←for←control;
VAR
i,j: integer; inlevel: boolean;
checker: ctp;
BEGIN (*CODE←FOR←CONTROL*)
CASE write←flag OF
write←internals:
BEGIN
write←header('LINK-CHAIN(S) ');
write←block←start(no,0,item←10);
WHILE globnewlink <> NIL DO
WITH globnewlink↑ DO
BEGIN
write←pair( both , refadr , ord( reftype↑.selfstp ));
globnewlink := next
END;
inlevel := true;
checker := localpfptr;
WHILE (checker <> NIL) AND inlevel DO
WITH checker↑ DO
IF pflev = level THEN
BEGIN
IF pfaddr <> 0 THEN
FOR i := 0 TO maxlevel DO
IF linkchain[i] <> 0 THEN
write←pair(both,linkchain[i],pfaddr-i);
checker:= pfchain
END
ELSE
inlevel := false;
IF level > 1 THEN
localpfptr := checker;
WHILE firstkonst <> NIL DO
WITH firstkonst↑, constptr↑ DO
BEGIN
write←pair(both,addr,kaddr);
IF (cclass IN [pset,strd]) AND double←chain THEN
write←pair(both,addr-1,kaddr+1);
firstkonst:= nextkonst
END;
inlevel := true;
WHILE (declscalptr <> NIL) AND inlevel DO
WITH declscalptr↑ DO
IF (level = tlev) OR ((level = 1) AND (tlev = 0)) THEN
BEGIN
IF request THEN
write←pair(both,vectorchain,vectoraddr);
declscalptr := nextscalar
END
ELSE
inlevel := false;
inlevel := true;
WHILE (last←label <> NIL) AND inlevel DO
WITH last←label↑ DO
IF scope = level THEN
BEGIN
IF goto←chain <> 0 THEN
IF label←address = 0 THEN
error←with←text(214,name)
ELSE
write←pair(both,goto←chain,label←address);
last←label := next
END
ELSE
inlevel := false;
IF level = 1 THEN
BEGIN
j := 0;
FOR i := 1 TO jumper DO
BEGIN
IF jump←table[i] <> 0 THEN
BEGIN
write←pair(both,jump←table[i],jump←address + j);
write←pair(both,jump←table[i] + 1, jump←address + j + 1);
j := j + 2
END
END
END
END;
write←end:
BEGIN
write←header('HIGHSEG-BREAK ');
write←block←start(no,0,item←5);
write←pair(right,0,highest←code);
write←header('LOWSEG-BREAK ');
lic := 0;
write←pair(right,0,lcmain); put←relocatable←code
END;
write←start:
IF NOT external THEN
BEGIN
write←header('START-ADDRESS ');
write←block←start(no,0,item←7);
write←pair(right,0,start←address)
END;
write←entry:
IF external THEN
BEGIN
write←block←start(no,0,item←4);
FOR i := 2 TO entries DO
write←identifier(entry←symbol,entry[i])
END;
write←name:
BEGIN
write←block←start(no,0,item←6);
write←identifier(entry←symbol,programname)
END;
write←hiseg:
BEGIN
llist←code := false;
write←block←start(no,0,item←3);
write←pair(right,400000B,400000B)
END
END (*CASE*)
END (*CODE←FOR←CONTROL*) ;
PROCEDURE code←for←symbols;
VAR
save←list←code: boolean;
switchflag: flagrange; checker: ctp;
BEGIN (*CODE←FOR←SYMBOLS*)
write←header('ENTRY-POINT(S) ');
write←block←start(no,0,item←2);
IF NOT external THEN
BEGIN
write←identifier(local←symbol,programname);
write←pair(right,0,start←address);
END
ELSE
BEGIN
checker := localpfptr;
WHILE checker <> NIL DO
WITH checker↑ DO
BEGIN
IF pfaddr <> 0 THEN
BEGIN
write←identifier(local←symbol,name);
write←pair(right,0,pfaddr)
END;
checker:= pfchain
END;
save←list←code := list←code; list←code := false;
checker := localpfptr;
WHILE checker <> NIL DO
WITH checker↑ DO
BEGIN
IF pfaddr <> 0 THEN
BEGIN
write←identifier(global←symbol,name);
write←pair(right,0,pfaddr)
END;
checker := pfchain
END;
list←code := save←list←code
END;
IF NOT external THEN
BEGIN
switchflag:= global←symbol;
write←header('ENTRY-SYMBOL(S) ');
END
ELSE
BEGIN
switchflag:= extern←symbol; write←header('EXTERN-SYMBOL(S) ')
END;
fileptr := sfileptr;
WHILE fileptr <> NIL DO
WITH fileptr↑, fileident↑ DO
BEGIN
IF vaddr <> 0 THEN
BEGIN
write←identifier(switchflag,name);
write←pair(right,0,vaddr)
END;
fileptr:= nextftp
END;
IF NOT external THEN
write←header('EXTERN-SYMBOL(S) ');
checker:= externpfptr;
WHILE checker <> NIL DO
WITH checker↑ DO
BEGIN
IF linkchain[0] <> 0 THEN
BEGIN
IF pflev = 0 THEN
write←identifier(extern←symbol,externalname)
ELSE
write←identifier(extern←symbol,name);
write←pair(right,0,linkchain[0])
END;
checker:= pfchain
END;
FOR support←index := first(support←index) TO last(support←index) DO
IF runtime←support.link[support←index] <> 0 THEN
BEGIN
write←identifier(extern←symbol,runtime←support.name[support←index]);
write←pair(right,0,runtime←support.link[support←index])
END;
IF debug THEN
BEGIN
write←identifier(extern←symbol,runtime←support.name[enterdebug]);
write←pair(right,0,debug←stop);
write←identifier(extern←symbol,runtime←support.name[initializedebug]);
write←pair(right,0,debug←initialization)
END;
IF NOT (debug OR external) THEN
BEGIN
write←identifier(extern←symbol,runtime←support.name[overflow]);
write←pair(no,0,jbapr)
END
END (*CODE←FOR←SYMBOLS*) ;
PROCEDURE code←for←libraries;
VAR
i, j, l: integer;
BEGIN (*CODE←FOR←LIBRARIES*)
write←header('LINK-LIBRARIE(S) ');
write←block←start(no,0,item←17);
FOR l := 1 TO 2 DO
BEGIN
FOR i := 1 TO library←index DO
WITH library[library←order[i]] DO
IF called THEN
WITH change DO
BEGIN
FOR j := 1 TO 6 DO wsixbit[j] := ord(name[j]) - 40B;
write←identifier(sixbit←symbol,name);
write←pair(no,projnr,prognr);
FOR j := 1 TO 6 DO wsixbit[j] := ord(device[j]) - 40B;
write←identifier(sixbit←symbol,device); lic := lic + 1
END;
i := 1;
FOR language←index := fortransy DOWNTO pascalsy DO
WITH library[language←index] DO
BEGIN
called := (NOT chained AND called) OR ((language←index = pascalsy) AND NOT called);
library←order[i] := language←index; i := i + 1
END;
library←index := 2
END
END (*CODE←FOR←LIBRARIES*);
BEGIN (*WRITE←MACHINE←CODE*)
IF NOT error←flag AND NOT no←code←gen THEN
BEGIN (* 22. AVOID CODE GENERATION IN CASE OF AN ERROR.*)
put←code←array := false;
space←w := 2; space←c := 0;
llist←code := list←code;
CASE write←flag OF
write←fileblocks:
code←for←fileblocks;
write←globals :
code←for←globals;
write←code :
code←for←instructions;
write←debug :
code←for←debug;
write←symbols :
code←for←symbols;
write←internals,
write←entry,
write←end,
write←start,
write←hiseg,
write←name :
code←for←control;
write←library :
code←for←libraries
END (*CASE*);
IF list←code AND (write←flag > write←hiseg) THEN
writeln(list)
END (* IF NOT ERROR←FLAG *)
ELSE
IF error←flag THEN
BEGIN
lastbtp := NIL;
declscalptr := NIL
END;
END (*WRITE←MACHINE←CODE*);
(* STATEMENT[ AUXILIAR PROCEDURES. *)
PROCEDURE statement(fsys,statends: setofsys);
TYPE
valuekind = (onregc,onfixedregc,truejmp,falsejmp);
VAR
lcp: ctp; j: integer;
PROCEDURE expression(fsys: setofsys; fvalue:valuekind);
FORWARD;
PROCEDURE makereal(VAR fattr: attr); (*CODE TO CONVERT FROM INTEGER TO REAL*)
BEGIN (*MAKEREAL*)
IF fattr.typtr=intptr THEN
BEGIN
load(fattr);
macro3(551B(*HRRZI*),reg1,fattr.reg);
support(convertintegertoreal);
fattr.typtr := realptr
END;
IF gattr.typtr=intptr THEN
makereal(gattr)
END (*MAKEREAL*);
PROCEDURE selector(fsys: setofsys; fcp: ctp);
VAR
lattr: attr; lcp: ctp; lsp: stp;
lmin,lmax,indexvalue,indexoffset: integer;
oldic: acrange;
bytes: bitrange;
PROCEDURE sublowbound; (*CODE TO ADJUST A SUBINDEX BY THE LOW BOUND OF ITS TYPE*)
BEGIN (*SLOWBOUND*)
IF lmin > 0 THEN
macro3(275B(*SUBI*),regc,lmin)
ELSE
IF lmin < 0 THEN
macro3(271B(*ADDI*),regc,-lmin);
IF runtime←check THEN
BEGIN
macro3(301B(*CAIL*),regc,0);
macro3(303B(*CAILE*),regc,lmax-lmin);
support(indexerror)
END
END (*SLOWBOUND*);
BEGIN (*SELECTOR*)
WITH fcp↑, gattr DO
BEGIN
typtr := idtype; kind := varbl; packfg := notpack; vclass := klass;
CASE klass OF
vars:
BEGIN
vlevel := vlev; dplmt := vaddr; indexr := 0;
IF vlev > 1 THEN
vrelbyte:= no
ELSE
vrelbyte:= right;
IF idtype↑.form = files THEN
last←file:= fcp
ELSE
last←file:= NIL;
indbit := ord(vkind)
END;
field:
WITH display[disx] DO
IF occur = crec THEN
BEGIN
vlevel := clev; packfg := packf; vrelbyte := crelbyte;
IF packfg = packk THEN
BEGIN
vbyte := fldbyte;
dplmt := cdspl
END
ELSE
dplmt := cdspl+fldaddr;
indexr := cindr; indbit:=cindb
END
ELSE
error(171);
func:
IF pfdeckind = standard (*STANDARD FUNCTION*) THEN
error(502)
ELSE
IF pflev = 0 THEN
error(502) (*EXTERNAL FUNCTION*)
ELSE
IF pfkind = formal (*FORMAL FUNCTION*) THEN
error(456)
ELSE
BEGIN
vlevel := pflev+1;
vrelbyte := no;
IF NOT activated THEN
error(509);
dplmt := 1; (* THE RELATIVE ADDRESS OF THE FUNCTION'S RESULT *)
indexr :=0;
indbit :=0
END
END (*CASE*)
END (*WITH*);
iferrskip(166,selectsys + fsys);
WHILE sy IN selectsys DO
BEGIN
(*[*)
IF sy = lbrack THEN
BEGIN
IF gattr.indbit = 1 THEN
get←parameter←address;
oldic := gattr.indexr;
indexoffset := 0 ;
LOOP
lattr := gattr; indexvalue := 0 ;
WITH lattr DO
IF typtr <> NIL THEN
BEGIN
IF typtr↑.form <> arrays THEN
BEGIN
error(307); typtr := NIL
END;
lsp := typtr
END;
insymbol;
expression(fsys + [comma,rbrack],onregc);
IF gattr.kind<>cst THEN
load(gattr)
ELSE
indexvalue := gattr.cval.ival ;
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.form <> scalar THEN
error(403);
IF lattr.typtr <> NIL THEN
WITH lattr,typtr↑ DO
BEGIN
IF comptypes(inxtype,gattr.typtr) THEN
BEGIN
IF inxtype <> NIL THEN
BEGIN
getbounds(inxtype,lmin,lmax);
IF gattr.kind = cst THEN
IF (indexvalue < lmin) OR (indexvalue > lmax) THEN
error(263)
END
END
ELSE
error(457);
typtr := aeltype
END
EXIT IF sy <> comma;
WITH lattr DO
IF typtr<>NIL THEN
IF gattr.kind = cst THEN
dplmt := dplmt + ( indexvalue - lmin ) * typtr↑.size
ELSE
BEGIN
sublowbound;
IF typtr↑.size > 1 THEN
macro3(221B(*IMULI*),regc,typtr↑.size);
IF oldic = 0 THEN
oldic := regc
ELSE
IF oldic > regcmax THEN
BEGIN
macro3(270B(*ADD*),regc,oldic);
oldic := regc
END
ELSE
BEGIN
macro3(270B(*ADD*),oldic,regc) ;
regc := regc - 1
END;
indexr := oldic
END ;
gattr := lattr
END (*LOOP*);
WITH lattr DO
IF typtr <> NIL THEN
BEGIN
IF gattr.kind = cst THEN
indexoffset := ( indexvalue - lmin ) * typtr↑.size
ELSE
BEGIN
IF (typtr↑.size > 1) OR runtime←check THEN
sublowbound
ELSE
indexoffset := -lmin;
IF typtr↑.size > 1 THEN
macro3(221B(*IMULI*),regc,typtr↑.size);
indexr := regc
END ;
IF lsp↑.arraypf THEN
BEGIN
bytes := bitmax DIV lsp↑.aeltype↑.bitsize;
IF gattr.kind = cst THEN
BEGIN
bpaddr := indexoffset MOD bytes + lsp↑.arraybpaddr + 1;
indexr := oldic;
indexoffset := indexoffset DIV bytes
END
ELSE
BEGIN
increment←regc;
IF indexr=oldic THEN
BEGIN
increment←regc; indexr := 0
END;
macro4(571B(*HRREI*),regc,indexr,indexoffset);
increment←regc;
regc := regc-1; indexoffset := 0;
macro3(231B(*IDIVI*),regc,bytes);
macro4r(200B(*MOVE*),regc-1,regc+1,lsp↑.arraybpaddr+1);
bpaddr := regc-1; indexr := regc
END;
packfg := packk
END (*ARRAYPACKFLAG*);
dplmt := dplmt + indexoffset ;
kind := varbl; vclass := vars;
IF ( oldic <> indexr ) AND ( oldic <> 0 ) THEN
BEGIN
IF oldic > regcmax THEN
macro3(270B(*ADD*),indexr,oldic)
ELSE
BEGIN
macro3(270B(*ADD*),oldic,indexr);
regc := regc - 1;
indexr := oldic
END
END
END (*WITH.. IF TYPTR <> NIL*) ;
gattr := lattr ;
IF sy = rbrack THEN
insymbol
ELSE
error(155)
END (*IF SY = LBRACK*)
ELSE
(*.*)
IF sy = period THEN
BEGIN
WITH gattr DO
BEGIN
IF typtr <> NIL THEN
IF typtr↑.form <> records THEN
BEGIN
error(308); typtr := NIL
END;
IF indbit=1 THEN
get←parameter←address;
insymbol;
IF sy = ident THEN
BEGIN
IF typtr <> NIL THEN
BEGIN
searchsection(typtr↑.fstfld,lcp);
IF lcp = NIL THEN
BEGIN
error(309); typtr := NIL
END
ELSE
WITH lcp↑ DO
BEGIN
typtr := idtype; packfg := packf;
IF packfg = packk THEN
BEGIN
vclass := field; vbyte := fldbyte
END
ELSE
dplmt := dplmt + fldaddr
END
END;
insymbol
END (*SY = IDENT*)
ELSE
error(209)
END (*WITH GATTR*)
END (*IF SY = PERIOD*)
ELSE
(*↑*)
BEGIN
IF gattr.typtr <> NIL THEN
WITH gattr,typtr↑ DO
IF form IN [pointer,files] THEN
BEGIN
IF form = pointer THEN
typtr := eltype
ELSE
typtr := filtype;
IF typtr <> NIL THEN
BEGIN
loadnoptr := false;
load(gattr); loadnoptr := true;
(* 12. CHECK FOR ZERO OR NIL POINTER *)
IF runtime←check AND (form = pointer) THEN
BEGIN
macro3(302B(*CAIE*),reg,0);
macro3(306B(*CAIN*),reg,377777B);
support(badpointer);
END;
WITH fcp↑ DO
IF (idtype↑.form = files) AND (vlev = 0) AND external THEN
BEGIN
vaddr:= ic-1; code←reference↑[cix] := externref
END;
indexr := reg; dplmt := 0; indbit:=0; packfg := notpack; kind := varbl;
vrelbyte:= no; vclass := vars
END
END
ELSE
error(407);
insymbol
END (*↑*);
iferrskip(166,fsys + selectsys)
END (*WHILE*);
WITH gattr DO
IF typtr<>NIL THEN
IF typtr↑.size = 2 THEN
BEGIN
IF indbit = 1 THEN
get←parameter←address;
IF (indexr>regin) AND (indexr<=regcmax) THEN
increment←regc
END
END (*SELECTOR*) ;
(* CALL[ ... *)
PROCEDURE call(fsys: setofsys; fcp: ctp);
LABEL
666;
VAR
lkey: integer;
lclass: idclass;
lsupport: supports;
tty←message, noload, lfollowerror, no←right←parent, buffer←variable : boolean;
PROCEDURE getfilename(default←name:alfa; followsys: setofsys);
(*PARSES THE FIRST PARAMETER IN CALLS TO FILE-RELATED
PROCEDURES AND FUNCTIONS, OR DEFAULTS IT TO THE
APPROPRIATE STANDARD FILE*)
VAR
lcp : ctp ; lvlev: levrange; default,default←tty : boolean ;
lsy: symbol; lid: alfa;
BEGIN (*GETFILENAME*)
default := true ; default←tty := false; no←right←parent := true;
buffer←variable := false;
IF sy = lparent THEN
BEGIN
no←right←parent := false;
insymbol ;
IF sy = ident THEN
BEGIN
searchid([konst,vars,field,proc,func],lcp);
IF lcp <> NIL THEN
WITH lcp↑,idtype↑ DO
IF idtype <> NIL THEN
BEGIN
IF form = files THEN
BEGIN
IF arrow IN followsys THEN
insymbol;
IF sy <> arrow THEN
BEGIN
default := false;
IF
(((lkey IN [2,4,7,8,10,11,17,19,28]) AND (lclass = proc)) OR
((lkey = 11) AND (lclass = func))) AND
(file←form <> text←file) THEN
error(366)
END
ELSE
buffer←variable := true
END;
IF klass = vars THEN
lvlev := vlev
ELSE
lvlev := 1
END;
IF (lvlev = 0) AND
(id = 'TTY ') AND
((default←name = 'OUTPUT ') OR (default←name = 'TTYOUTPUT ')) AND
NOT buffer←variable THEN
BEGIN
default := true; default←tty := true;
default←name := 'TTYOUTPUT '
END
END (*SY = IDENT*)
END (*SY = LPARENT*);
IF no←right←parent
AND (sy IN (facbegsys + [addop])) AND NOT ( (lclass=func) AND (lkey IN [10,11]) ) THEN
error(156);
ttyread := (NOT default AND (id = 'TTY ')) OR
(default AND (default←name = 'TTY ')) OR ttyread;
outputwrite := outputwrite OR (NOT default AND (id = 'OUTPUT ')) OR
(default AND (default←name = 'OUTPUT ')); (* 13. REWRITE OUTPUT ONLY IF NEEDED.*)
IF default THEN
BEGIN
lid := id; id := default←name;
searchid([vars],lcp);
IF lcp↑.idtype↑.form <> files THEN
searchsection(display[0].fname,lcp);
id := lid
END ;
lsy := sy; sy := comma; lfollowerror := followerror;
selector(fsys + [comma,rparent],lcp) ;
sy := lsy; followerror := lfollowerror;
IF noload THEN
WITH gattr DO
BEGIN
IF (indbit <> 0) OR ((lcp↑.vlev = 0) AND external) THEN
load←address;
CASE lkey OF
10:
dplmt := dplmt + fileof; (*EOF*)
11:
dplmt := dplmt + fileol; (*EOLN*)
17:
dplmt := dplmt + fillnr (*GETLINENR*)
END
END
ELSE
load←address;
IF buffer←variable THEN
BEGIN
searchid([vars],lcp);
selector(fsys + (followsys-[arrow]),lcp)
END;
IF NOT default OR default←tty THEN
BEGIN
IF NOT (arrow IN followsys) THEN
insymbol;
IF NOT (sy IN followsys-[arrow]) THEN
error(458)
ELSE
IF sy = comma THEN
insymbol
END
END (*GETFILENAME*) ;
PROCEDURE variable(fsys: setofsys);
VAR
lcp: ctp;
BEGIN (*VARIABLE*)
IF sy = ident THEN
BEGIN
searchid([vars,field],lcp); insymbol
END
ELSE
BEGIN
error(209); lcp := uvarptr
END;
selector(fsys,lcp)
END (*VARIABLE*) ;
PROCEDURE getputresetrewrite;
VAR
default : ARRAY [1..4] OF boolean;
i : integer;
lattr: attr;
PROCEDURE getstringaddress(length: integer) ;
BEGIN (*GETSTRINGADDRESS*)
IF sy <> rparent THEN
BEGIN
expression(fsys + [comma],onfixedregc);
WITH gattr DO
IF string(typtr) THEN
WITH typtr↑ DO
IF arraypf AND (size=2) AND (inxtype↑.vmax.ival-inxtype↑.vmin.ival+1 = length) THEN
BEGIN
default[i] := false; load←address
END
ELSE
error(458)
ELSE
error(458)
END
END (*GETSTRINGADDRESS*);
BEGIN (*GETPUTRESETREWRITE*)
CASE lkey OF
1,2 :
getfilename('INPUT ',[rparent]); (*GET, GETLN*)
3,4 :
getfilename('OUTPUT ',[rparent]); (*PUT, PUTLN*)
5 :
getfilename('INPUT ',[comma,rparent]); (*RESET*)
6 :
getfilename('OUTPUT ',[comma,rparent]) (*REWRITE*)
END;
IF lkey IN [5,6] THEN
(*RESET, REWRITE*)
BEGIN
FOR i := 1 TO 4 DO default[i] := true;
i := 1;
getstringaddress(9) (* OF FILENAME *) ;
WHILE (i<3) AND NOT default[1] AND (sy=comma) DO (*PROTECTION, PPN, DEVICE (?)*)
BEGIN
i := i + 1;
insymbol; expression(fsys + [comma],onfixedregc);
IF gattr.typtr <> NIL THEN
IF comptypes(gattr.typtr,intptr) THEN
BEGIN
load(gattr); default[i] := false
END
ELSE
error(458)
END;
IF NOT default[3] THEN
(*DEVICE*)
BEGIN
i := i+1;
IF sy = comma THEN
insymbol;
getstringaddress(6) (* OF DEVICE NAME *)
END;
FOR i := 1 TO 4 DO
IF default[i] THEN
BEGIN
increment←regc;
macro2(400B(*SETZ*),regc)
END
END (*IF LKEY IN [5,6]*) (*RESET, REWRITE*);
CASE lkey OF
1: (*GET*)
BEGIN
lsupport := getfile;
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.file←form = text←file THEN
lsupport := getcharacter
END;
2: (*GETLN*)
IF comptypes(gattr.typtr,textptr) THEN
lsupport := getline
ELSE
error(366) ;
3: (*PUT*)
lsupport := putfile ;
4: (*PUTLN*)
IF comptypes(gattr.typtr,textptr) THEN
lsupport := putline
ELSE
error(366) ;
5: (*RESET*)
lsupport := resetfile ;
6: (*REWRITE*)
lsupport := rewritefile
END ;
support(lsupport);
IF (lkey = 1) AND (gattr.typtr <> NIL) AND runtime←check THEN
IF gattr.typtr↑.filtype <> NIL THEN
(*BOUNDARY CHECK FOR FILES OF SUBRANGE*)
WITH gattr.typtr↑.filtype↑ DO
IF (form = subrange) AND (gattr.typtr↑.file←form <> text←file) THEN
BEGIN
increment←regc; macro4(200B(*MOVE*),regc,regc-1,filcmp);
lattr.kind := cst; lattr.typtr := rangetype;
lattr.cval := vmax; generate←code(317B(*CAMG*),regc,lattr);
lattr.cval := vmin; generate←code(315B(*CAMGE*),regc,lattr);
support(inputerror)
END;
END (*GETPUTRESETREWRITE*);
PROCEDURE call←support;
BEGIN (*CALL←SUPPORT*)
IF (lsupport IN [readirange..wrtdset]) AND ((sy = comma) OR (lkey IN [8,11])) THEN
BEGIN
IF NOT reg2←saved THEN
BEGIN
reg2←saved := true;
reg2←location := lc;
lc := lc + 1;
IF lc > lcmax THEN
lcmax := lc
END;
macro4(202B(*MOVEM*),regc,basis,reg2←location);
support(lsupport);
macro4(200B(*MOVE*),regc,basis,reg2←location)
END
ELSE
support(lsupport)
END (*CALL←SUPPORT*);
PROCEDURE readreadln; (*READ A LIST OF PARAMETERS FROM A TEXT FILE*)
VAR
boundclass: cstclass;
lattr: attr;
baseform: structform;
%3 SAVREGC: INTEGER; (* 16. \
BEGIN (*READREADLN*)
getfilename('INPUT ',[arrow,rparent,comma]);
IF (lkey = 7) OR ((lkey = 8) AND (sy = ident)) OR buffer←variable THEN
LOOP
IF NOT buffer←variable THEN
BEGIN
%3 SAVREGC := REGC; (* 16. \
variable(fsys + [comma]);
%3 (* 16. FIX THE MOD BUG (KO)
IF (REGC > SAVREGC+1) AND (GATTR.INDEXR > SAVREGC) THEN
BEGIN
MACRO3 (200B(*MOVE,REGC-1,REGC);
REGC := REGC - 1;
GATTR.INDEXR := GATTR.INDEXR - 1;
END;
(* 16. END OF FIX. \
load←address
END;
lsupport := readinteger;
buffer←variable := false;
WITH gattr DO
IF typtr <> NIL THEN
IF typtr↑.form IN [scalar,subrange,power] THEN
BEGIN
IF typtr = charptr THEN
typtr := asciiptr;
baseform := typtr↑.form;
IF typtr↑.form = power THEN
BEGIN
typtr := typtr↑.elset;
IF comptypes(typtr,asciiptr) THEN
BEGIN
macro3(551B(*HRRZI*),regc+1,offset);
macro3(551B(*HRRZI*),regc+2,basemax + offset)
END
END;
IF typtr <> NIL THEN
IF typtr↑.form = subrange THEN
BEGIN
IF comptypes(realptr,typtr↑.rangetype) THEN
boundclass := reel
ELSE
boundclass := int;
lattr.kind := cst;
lattr.cval := typtr↑.vmin; macro2(200B(*MOVE*),regc+1); deposit←constant(boundclass,lattr);
lattr.cval := typtr↑.vmax; macro2(200B(*MOVE*),regc+2); deposit←constant(boundclass,lattr);
typtr := typtr↑.rangetype
END
ELSE
IF typtr↑.scalkind = declared THEN
BEGIN
macro3(551B(*HRRZI*),regc+2,typtr↑.dimension);
macro2(400B(*SETZ*),regc+1)
END;
IF typtr <> NIL THEN
IF typtr↑.scalkind = declared THEN
WITH typtr↑ DO
BEGIN
request := true; macro3r(551B(*HRRZI*),regc+3,vectorchain);
code←reference↑[cix] := constref; vectorchain := ic-1;
lsupport := read←support[declaredform,baseform]
END
ELSE
BEGIN
IF typtr = intptr THEN
lsupport := read←support[integerform,baseform]
ELSE
IF comptypes(typtr,asciiptr) THEN
lsupport := read←support[charform,baseform]
ELSE
IF typtr = realptr THEN
lsupport := read←support[realform,baseform]
ELSE
error(458)
END
END
ELSE
IF string(typtr) THEN
BEGIN
IF typtr↑.arraypf THEN
lsupport := readpackedstring
ELSE
lsupport := readstring;
WITH typtr↑.inxtype↑ DO macro3(551B(*HRRZI*),regc+1,vmax.ival-vmin.ival+1)
END
ELSE
(* 25. ACCEPT TYPE 'STRING' *)
IF typtr = sstringptr THEN
IF stringpack THEN
lsupport := readpseudostring
ELSE
error (321)
ELSE
(* 25.*)
error(169);
regc := regin + 1;
call←support
EXIT IF sy <> comma;
insymbol
END;
IF lkey = 8 THEN
support(getline)
END (*READREADLN*) ;
PROCEDURE breakcall; (*SEND THE OUTPUT BUFFER TO THE FILE*)
BEGIN (*BREAKCALL*)
getfilename('TTYOUTPUT ',[rparent]);
support(putbuffer)
END (*BREAKCALL*);
PROCEDURE writewriteln; (*WRITE INTO A TEXT FILE A LIST OF PARAMETERS*)
VAR
llsp, lsp: stp;
default, realformat, declared←or←set: boolean;
%3 SAVREGC, (* 16. \
lsize, lmin, lmax: integer;
BEGIN (*WRITEWRITELN*)
IF NOT tty←message THEN
getfilename('OUTPUT ',[rparent,comma,arrow,colon]);
IF (lkey = 10) OR ((lkey = 11) AND (sy IN facbegsys + [addop])) OR buffer←variable THEN
LOOP
IF NOT buffer←variable THEN
BEGIN
%3 SAVREGC := REGC; (* 16. IDIV USES TWO REGISTERS. \
expression(fsys + [comma,colon],onfixedregc);
END;
lsp := gattr.typtr;
lsupport := writeinteger;
IF lsp <> NIL THEN
WITH lsp↑ DO
IF form <= power THEN
BEGIN
%3 (* 16. FIX THE MOD BUG.
IF (REGC > SAVREGC + 1) AND (GATTR.INDEXR >= REGC) THEN
BEGIN
MACRO3 (200B(*MOVE,REGC-1, REGC);
REGC := REGC-1;
GATTR.INDEXR := GATTR.INDEXR - 1;
END;
(* 16. END OF FIX. \
load(gattr);
declared←or←set := (form = power) OR ((form = scalar)
AND (scalkind = declared) AND NOT (lsp = boolptr))
END
ELSE
BEGIN
IF NOT buffer←variable THEN
load←address;
declared←or←set := false
END;
buffer←variable := false;
IF sy = colon THEN
(*FIELD WIDTH*)
BEGIN
insymbol;
expression(fsys + [comma,colon],onfixedregc);
IF gattr.typtr <> NIL THEN
BEGIN
IF gattr.typtr <> intptr THEN
error(458);
IF gattr.kind <> expr THEN
BEGIN
generate←code( 200B (*MOVE*) , regin+3 , gattr ) ;
regc := gattr.reg ;
END ;
END ;
default := false
END
ELSE
BEGIN
default := true;
increment←regc (*RESERVE REGISTER FOR DEFAULT VALUE*)
END ;
IF sy = colon (*SECOND FORMAT MODIFIER*) THEN
BEGIN
insymbol;
IF comptypes(lsp,intptr) THEN
BEGIN
IF (sy = ident) AND ((id='O ') OR (id='H ')) THEN
IF id = 'O ' THEN
lsupport := writeoctal
ELSE
lsupport := writehexadecimal
ELSE
error(262);
insymbol
END
ELSE
BEGIN
expression(fsys + [comma],onfixedregc);
IF gattr.typtr <> NIL THEN
IF gattr.typtr <> intptr THEN
error(458);
IF lsp <> realptr THEN
error(258);
load(gattr);
realformat := false
END
END
ELSE
realformat := true;
IF lsp <> intptr THEN
BEGIN
IF comptypes(lsp,asciiptr) THEN
lsupport := writecharacter
ELSE
IF lsp = realptr THEN
IF realformat THEN
lsupport := writedef1real
ELSE
lsupport := writereal
ELSE
IF lsp = boolptr THEN
lsupport := writeboolean
ELSE
WITH lsp↑ DO
IF string(lsp) THEN
BEGIN
IF inxtype <> NIL THEN
BEGIN
getbounds(inxtype,lmin,lmax);
lsize := lmax-lmin+1
END
ELSE
lsize := 0;
macro3(551B(*HRRZI*),regin+4,lsize);
IF arraypf THEN
lsupport := writepackedstring
ELSE
lsupport := writestring
END
ELSE
IF (lsp <> NIL) AND declared←or←set THEN
BEGIN
IF form = power THEN
BEGIN
IF elset <> NIL THEN
IF elset↑.form = subrange THEN
llsp := elset↑.rangetype
ELSE
llsp := elset
END
ELSE
llsp := lsp;
IF llsp <> NIL THEN
IF llsp↑.scalkind = declared THEN
WITH llsp↑ DO
BEGIN
IF default THEN
macro3(515B(*HRLZI*),regc,dimension)
ELSE
macro3(505B(*HRLI*),regc,dimension);
macro3r(551B(*HRRZI*),regc+1,vectorchain);
vectorchain := ic-1; request := true;
code←reference↑[cix] := constref; lsupport := write←support[declaredform,lsp↑.form]
END
ELSE
BEGIN
IF default THEN
macro2(400B(*SETZ*),regc);
IF llsp = intptr THEN
lsupport := write←support[integerform,form]
ELSE
IF comptypes(llsp,asciiptr) THEN
lsupport := write←support[charform,form]
ELSE
error(458)
END
END
ELSE
(* 25. ACCEPT TYPE 'STRING'*)
IF lsp = sstringptr THEN
IF stringpack THEN
lsupport := writepseudostring
ELSE
error(321)
ELSE
(* 25.*)
error(458)
END;
IF default AND NOT declared←or←set THEN
lsupport := succ( lsupport );
regc :=regin + 1;
call←support
EXIT IF sy <> comma;
insymbol
END (* LOOP *);
IF lkey = 11 THEN
support(putline)
END (*WRITEWRITELN*) ;
PROCEDURE messagecall;
(* MESSAGE(<ARGUMENT LIST>)
IS EQUIVALENT TO
WRITELN(TTY);
WRITELN(TTY,<ARGUMENT LIST>);
BREAK(TTY); *)
BEGIN (*MESSAGECALL*)
increment←regc;
macro3r(551B(*HRRZI*),regc,stdfileptr[4]↑.vaddr);
IF external THEN
stdfileptr[4]↑.vaddr := ic - 1;
support(putline);
lkey := 10; tty←message := true;
writewriteln;
tty←message := false;
support(putline); support(putbuffer)
END (*MESSAGECALL*);
(* ... *)
PROCEDURE packunpack;
(******************************************************************************
*
* PACK(A,I,Z<,J<,L>>) EXECUTES: FOR K := 0 TO L1-1 DO Z[J1+K] := A[I+K]
*
* UNPACK(Z,A,I<,J<,L>>) EXECUTES: FOR K := 0 TO L1-1 DO A[I+K] := Z[J1+K]
*
* A IS AN ARRAY OF A SCALAR-TYPE,
* Z IS A PACKED ARRAY OF THIS TYPE (SO THE BITSIZE MUST BE <= 18),
* I IS THE ABSOLUTE START-INDEX IN A,
* J IS THE ABSOLUTE START-INDEX IN Z,
* L IS THE NUMBER OF ELEMENTS TO BE PACKED/UNPACKED,
* J1 IS J (DEFAULT: LOWERBOUND(Z)),
* L1 IS L (DEFAULT: MIN(UPPERBOUND(Z)-J1,UPPERBOUND(A)-I)+1),
* K IS NOT DENOTED ELSEWHERE IN THE PROGRAM.
*
******************************************************************************)
VAR
a,i,z,j,l: attr; lregc: acrange;
length, astart, zstart, amax, amin, zmax, zmin, packfactor: integer;
default←length: boolean;
PROCEDURE adjust( VAR fattr: attr; fbound: integer);
BEGIN (*ADJUST*)
load(fattr);
IF fbound < 0 THEN
macro3(271B(*ADDI*),fattr.reg,-fbound)
ELSE
IF fbound > 0 THEN
macro3(275B(*SUBI*),fattr.reg,fbound);
IF runtime←check THEN
BEGIN
macro2(305B(*CAIGE*),fattr.reg);
support(indexerror)
END
END (*ADJUST*);
PROCEDURE getoffset( VAR fattr: attr; fsys: setofsys; comptyptr: stp);
BEGIN (*GETOFFSET*)
expression(fsys,onregc); fattr := gattr;
IF NOT error←flag THEN
WITH fattr DO
IF typtr <> NIL THEN
IF NOT comptypes(typtr,comptyptr) THEN
error(458);
IF (sy=comma) AND (comma IN fsys) THEN
insymbol
ELSE
IF (sy <> rparent) OR NOT (rparent IN fsys) THEN
error(458)
END (*GETOFFSET*);
PROCEDURE getvar( VAR fattr: attr; fsys: setofsys; comptyptr: stp);
BEGIN (*GETVAR*)
variable(fsys); load←address; fattr := gattr;
IF NOT error←flag THEN
WITH fattr DO
IF typtr <> NIL THEN
WITH typtr↑ DO
IF form = arrays THEN
BEGIN
IF comptyptr = NIL THEN
IF lkey = 12 THEN
BEGIN
IF arraypf THEN
error(458)
END
ELSE
BEGIN
IF NOT arraypf THEN
error(458)
END
ELSE
IF NOT ((arraypf <> comptyptr↑.arraypf) AND
comptypes(aeltype,comptyptr↑.aeltype) AND
comptypes(inxtype,comptyptr↑.inxtype)) THEN
error(458);
kind := expr;
IF arraypf THEN
BEGIN
reg := reg1; regc := regc-1;
code←array↑.instruction[cix].ac := reg1
END
ELSE
reg := indexr
END
ELSE
error(458);
IF (sy = comma) AND (comma IN fsys) THEN
insymbol
ELSE
IF (sy <> rparent) OR NOT (rparent IN fsys) THEN
error(458)
END (*GETVAR*);
BEGIN (* PACKUNPACK *)
lregc := regc; default←length := true;
IF lkey = 12 THEN
BEGIN
getvar(a,[comma],NIL);
IF a.typtr <> NIL THEN
getoffset(i,[comma],a.typtr↑.inxtype)
ELSE
getoffset(i,[comma],NIL);
getvar(z,[comma,rparent],a.typtr)
END
ELSE
BEGIN
getvar(z,[comma],NIL);
getvar(a,[comma],z.typtr);
IF a.typtr <> NIL THEN
getoffset(i,[comma,rparent],a.typtr↑.inxtype)
ELSE
getoffset(i,[comma,rparent],NIL)
END;
IF NOT error←flag THEN
BEGIN
getbounds(a.typtr↑.inxtype,amin,amax); amax := amax-amin;
getbounds(z.typtr↑.inxtype,zmin,zmax); zmax := zmax-zmin;
END;
WITH j DO
BEGIN
kind := cst; cval.ival := zmin
END;
WITH l DO
BEGIN
kind := cst; cval.ival := 0
END;
IF sy <> rparent THEN
BEGIN
IF z.typtr <> NIL THEN
getoffset(j,[comma,rparent],z.typtr↑.inxtype)
ELSE
getoffset(j,[comma,rparent],NIL);
IF sy <> rparent THEN
BEGIN
default←length := false;
getoffset(l,[rparent],intptr)
END
END;
IF NOT error←flag THEN
BEGIN
astart := 0; packfactor := bitmax DIV z.typtr↑.aeltype↑.bitsize;
IF (i.kind = cst) AND (j.kind = cst) AND (l.kind = cst) THEN
BEGIN
astart := i.cval.ival - amin;
zstart := j.cval.ival - zmin;
IF (astart >= 0) AND (zstart >= 0) THEN
BEGIN
length := min(zmax-zstart, amax-astart) + 1;
IF length >= 0 THEN
BEGIN
IF NOT default←length THEN
IF (l.cval.ival >= 0) AND (l.cval.ival <= length) THEN
length := l.cval.ival
ELSE
error(263);
macro3(505B(*HRLI*),a.reg,-length);
IF (zstart DIV packfactor) <> 0 THEN
macro3(271B(*ADDI*),z.reg,zstart DIV packfactor);
macro3r(200B(*MOVE*),regc+1,z.typtr↑.arraybpaddr+(zstart MOD packfactor))
END
ELSE
error(263)
END
ELSE
error(263)
END
ELSE
(* KIND <> CST *)
BEGIN
adjust(i,amin);
macro3(270B(*ADD*),a.reg,i.reg);
adjust(j,zmin);
IF runtime←check OR default←length THEN
BEGIN
macro3(275B(*SUBI*),i.reg,amax);
macro3(200B(*MOVE*),regc+1,j.reg);
macro3(275B(*SUBI*),regc+1,zmax);
macro3(315B(*CAMGE*),i.reg,regc+1);
macro3(200B(*MOVE*),i.reg,regc+1);
IF runtime←check THEN
BEGIN
macro2(303B(*CAILE*),i.reg);
support(indexerror)
END;
IF default←length THEN
macro4(505B(*HRLI*),a.reg,i.reg,-1)
END;
IF NOT default←length THEN
IF runtime←check OR (l.kind <> cst) THEN
BEGIN
generate←code(210B(*MOVN*),regc+1,l);
IF runtime←check THEN
BEGIN
macro2(307B(*CAIG*),l.reg);
macro3(315B(*CAMGE*),l.reg,i.reg);
support(indexerror)
END;
macro3(504B(*HRL*),a.reg,l.reg)
END
ELSE
macro3(505B(*HRLI*),a.reg,-l.cval.ival);
macro3(231B(*IDIVI*),j.reg,packfactor);
macro3(270B(*ADD*),z.reg,j.reg);
macro4r(200B(*MOVE*),regc+1,j.reg+1,z.typtr↑.arraybpaddr)
END;
IF lkey = 12 THEN
BEGIN
macro4(200B(*MOVE*),reg0,a.reg,astart);
macro3(136B(*IDPB*),reg0,regc+1)
END
ELSE
BEGIN
macro3(134B(*ILDB*),reg0,regc+1);
macro4(202B(*MOVEM*),reg0,a.reg,astart)
END;
macro3r(253B(*AOBJN*),a.reg,ic-2)
END (* IF NOT ERROR←FLAG *)
END (* PACKUNPACK *);
PROCEDURE newdispose;
(* "NEW" ALLOCATES STORAGE FOR A DYNAMIC VARIABLE
(F.E. A RECORD VARIANT) IN THE HEAP.
"DISPOSE" DE-ALLOCATES THE STORAGE OCCUPIED BY
SUCH A VARIABLE AND IN THIS IMPLEMENTATION IT
DE-ALLOCATES THE STORAGE OF ALL VARIABLES ALLOCATED
LATER THAN THE SPECIFIED ONE TOO.
THIS IS DUE TO THE STACK-LIKE HEAP MANAGEMENT
WITH ONLY "NEWREG" POINTING TO THE LAST ALLOCATED
WORD OF CORE*)
LABEL
777;
VAR
lsp,lsp1: stp; varts,lmin,lmax: integer;
lnlk : nlk;
lengthreg: acrange;
lsize,lsz: addrrange; lval: valu;
lattrc, lattr: attr; i,tagfc: integer;
tagfsav: ARRAY[0..tagfmax] OF RECORD
tagfval: integer;
tagtype: tagfwithid..tagfwithoutid;
CASE tpackkind: packkind OF
notpack,
hwordl,
hwordr: (tagfaddr: addrrange);
packk: (tagfbyte: bpointer)
END;
BEGIN (*NEWDISPOSE*)
increment←regc; variable(fsys + [comma,colon]);
IF lkey = 24 (*DISPOSE*) THEN
BEGIN
generate←code(200B(*MOVE*),reg0,gattr);
lengthreg := reg1
END
ELSE
lengthreg := regin + 1;
lsp := NIL; varts := 0; lsize := 0; tagfc := -1;
lattr := gattr;
IF gattr.typtr <> NIL THEN
WITH gattr.typtr↑ DO
IF form = pointer THEN
BEGIN
IF eltype <> NIL THEN
BEGIN
lsize := eltype↑.size;
IF eltype↑.form = records THEN
lsp := eltype↑.recvar
ELSE
IF eltype↑.form = arrays THEN
lsp := eltype
END
END
ELSE
error(458);
WHILE sy = comma DO
BEGIN
insymbol; constant(fsys + [comma,colon],lsp1,lval);
varts := varts + 1;
IF lsp <> NIL THEN
IF NOT (string(lsp) OR (lsp1 = realptr)) THEN
BEGIN
tagfc := tagfc + 1;
IF tagfc <= tagfmax THEN
IF lsp↑.form = tagfwithid THEN
BEGIN
IF lsp↑.tagfieldp <> NIL THEN
IF comptypes(lsp↑.tagfieldp↑.idtype,lsp1) THEN
WITH tagfsav[tagfc], lsp↑.tagfieldp↑ DO
BEGIN
tagfval := lval.ival;
tagtype := tagfwithid; tpackkind := packf;
IF tpackkind = packk THEN
tagfbyte := fldbyte
ELSE
tagfaddr := fldaddr
END
ELSE
error(458)
END
ELSE
IF lsp↑.form = tagfwithoutid THEN
IF comptypes(lsp↑.tagfieldtype,lsp1) THEN
tagfsav[tagfc].tagtype := tagfwithoutid
ELSE
error(458)
ELSE
error(358)
ELSE
BEGIN
error(409); tagfc := tagfmax
END;
lsp1 := lsp↑.fstvar;
WHILE lsp1 <> NIL DO
WITH lsp1↑ DO
IF varval.ival = lval.ival THEN
BEGIN
lsize := size; lsp := subvar; GOTO 777
END
ELSE
lsp1 := nxtvar;
lsize := lsp↑.size; lsp := NIL;
777:
END
ELSE
error(460)
ELSE
error(408)
END (*WHILE*) ;
IF sy = colon THEN
BEGIN
insymbol;
expression(fsys,onregc);
IF lsp = NIL THEN
error(408)
ELSE
IF lsp↑.form <> arrays THEN
error(259)
ELSE
BEGIN
IF NOT comptypes(gattr.typtr,lsp↑.inxtype) THEN
error(458);
lsz := 1; lmin := 1;
IF lsp↑.inxtype <> NIL THEN
getbounds(lsp↑.inxtype,lmin,lmax);
IF lsp↑.aeltype <> NIL THEN
lsz := lsp↑.aeltype↑.size;
load(gattr);
IF lsz <> 1 THEN
macro3(221B(*IMULI*),regc,lsz);
IF lsp↑.arraypf THEN
BEGIN
macro3(271B(*ADDI*),regc,lsp↑.aeltype↑.bitsize-1);
increment←regc; regc := regc - 1;
(*FOR TESTING BECAUSE IDIV WORKS ON AC+1 TOO*)
macro3(231B(*IDIVI*),regc,bitmax DIV lsp↑.aeltype↑.bitsize);
lsz := lsize - lsp↑.size + 1
END
ELSE
lsz := lsize - lsp↑.size - lsz*(lmin - 1);
macro4(551B(*HRRZI*),lengthreg,regc,lsz)
END
END
ELSE
macro3(551B(*HRRZI*),lengthreg,lsize);
IF lkey = 14 THEN
BEGIN
IF debug←switch THEN
BEGIN
macro3(540B(* HRR *),reg0,newreg);
IF lattr.typtr <> NIL THEN
IF lattr.typtr↑.eltype <> NIL THEN
BEGIN
macro3r(505B(* HRLI *), reg0,0);
code←reference↑[cix] := debugref;
new(lnlk);
WITH lnlk↑ DO
BEGIN
refadr := ic - 1;
reftype := lattr.typtr↑.eltype;
next := globnewlink;
globnewlink := lnlk;
END;
END
END;
support(allocate);
IF debug←switch THEN
BEGIN
macro3(360B(*SOJ*),newreg,0);
macro4(202B(*MOVEM*),reg0,newreg,0)
END;
regc := regin+1;
FOR i := 0 TO tagfc DO
WITH tagfsav[i] DO
BEGIN
IF tagtype = tagfwithid THEN
BEGIN
macro3(551B(*HRRZI*),reg0,tagfval);
CASE tpackkind OF
notpack:
macro4(202B(*MOVEM*),reg0,regc,tagfaddr);
hwordr:
macro4(542B(*HRRM*),reg0,regc,tagfaddr);
hwordl:
macro4(506B(*HRLM*),reg0,regc,tagfaddr);
packk :
BEGIN
WITH lattrc, cval, byte DO
BEGIN
kind := cst;
cval.byte := tagfbyte;
ireg := regc
END;
macro2(137B(*DPB*),reg0); deposit←constant(bptr,lattrc)
END
END(*CASE*)
END
END;
store(regc,lattr)
END
ELSE
support(free)
END (*NEWDISPOSE*) ;
PROCEDURE firstlast;
(* RETURN LOWER- OR UPPERBOUND OF "STANDARD SCALARS",
"DECLARED SCALARS" AND THEIR "SUBRANGES"*)
VAR
lmin, lmax: integer;
BEGIN (*FIRSTLAST*)
variable(fsys + [rparent]);
IF gattr.typtr <> NIL THEN
WITH gattr DO
IF NOT comptypes(realptr,typtr) THEN
BEGIN
getbounds(typtr,lmin,lmax);
kind := cst;
IF lkey = 21 THEN
cval.ival := lmin
ELSE
cval.ival := lmax;
IF typtr↑.form = subrange THEN
typtr := typtr↑.rangetype
END
ELSE
error(459)
END (*FIRSTLAST*);
PROCEDURE lowerupperbound;
(* RETURN LOWER- OR UPPERBOUND OF
ARRAY INDEX TYPE*)
VAR
lmin, lmax: integer;
BEGIN (*LOWERUPPERBOUND*)
variable(fsys + [rparent]);
IF gattr.typtr <> NIL THEN
WITH gattr DO
IF (typtr↑.form = arrays) AND (typtr↑.inxtype <> NIL) THEN
BEGIN
getbounds(typtr↑.inxtype,lmin,lmax);
kind := cst;
IF lkey = 15 THEN
cval.ival := lmin
ELSE
cval.ival := lmax;
IF typtr↑.inxtype↑.form = subrange THEN
typtr := typtr↑.inxtype↑.rangetype
ELSE
typtr := typtr↑.inxtype
END
ELSE
error(459)
END (*LOWERUPPERBOUND*);
PROCEDURE minmax;
(* THIS PROCEDURE GENERATES CODE FOR THE MIN/MAX FUNCTION.
THE MAXIMUM NUMBER OF SCALAR-TYPE EXPRESSIONS -EXCEPT REAL-
IS 72 *)
CONST
topp←offset = 2;
max←expr = 72;
VAR
i, j: integer;
lregc: acrange;
insert←size: coderange;
linstr: instrange;
first←expression, conversion: boolean;
selector: scalarform;
argument: PACKED ARRAY[1..max←expr] OF scalarform;
BEGIN (*MINMAX*)
first←expression := true;
conversion := false;
i := 1;
lregc := regc;
macro4(307B(*CAIG*),newreg,topp,0); insert←size := cix;
support(stackoverflow);
LOOP
expression(fsys + [comma,rparent], onfixedregc);
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.form <> scalar THEN
error(458)
ELSE
WITH gattr DO
BEGIN
load(gattr);
IF typtr = intptr THEN
argument[i] := integerform
ELSE
IF typtr = realptr THEN
argument[i] := realform
ELSE
IF comptypes(typtr,asciiptr) THEN
argument[i] := charform
ELSE
IF (typtr↑.scalkind = declared) AND (typtr <> boolptr) THEN
argument[i] := declaredform
ELSE
error(458);
macro4(202B(*MOVEM*),reg,topp,topp←offset + i);
IF first←expression THEN
BEGIN
first←expression := false; selector := argument[i]
END
ELSE
IF selector <> argument[i] THEN
IF [selector,argument[i]] <= [integerform,realform] THEN
BEGIN
conversion := true; selector := realform
END
ELSE
error(458)
END
EXIT IF sy <> comma;
i := i + 1;
IF i > max←expr THEN
BEGIN
error(458); i := 1
END;
insymbol;
regc := lregc
END;
IF (i > 1) AND NOT error←flag THEN
BEGIN
insert←address(no, insert←size, topp←offset + i);
IF conversion THEN
FOR j := 1 TO i DO
IF argument[j] = integerform THEN
BEGIN
macro4(551B(*HRRZI*),reg1,topp,topp←offset + j);
support(convertintegertoreal)
END;
increment←regc;
macro4(541B(*HRRI*),regc,topp,topp←offset + 2);
macro3(505B(*HRLI*),regc,-(i - 1));
macro4(200B(*MOVE*),gattr.reg,topp,topp←offset + 1);
IF lkey = 20 THEN
linstr := 315B(*CAMGE*)
ELSE
linstr := 313B(*CAMLE*);
macro4(linstr,gattr.reg,regc,0);
macro4(200B(*MOVE*),gattr.reg,regc,0);
macro3(253B(*AOBJN*),regc,ic - 2);
IF conversion THEN
gattr.typtr := realptr
END
END (*MINMAX*);
PROCEDURE getlinenrcall; (*ASSIGN THE CURRENT LINE NUMBER FROM A TEXT FILE
TO A PACKC5 PARAMETER*)
BEGIN (*GETLINENRCALL*)
getfilename('INPUT ',[comma]);
load(gattr);
variable(fsys);
IF comptypes(gattr.typtr,packc5ptr) THEN
store(regc,gattr)
ELSE
error(458)
END (*GETLINENRCALL*);
PROCEDURE pagecall; (*WRITE A PAGECALLMARK INTO A TEXT FILE*)
BEGIN (*PAGECALL*)
getfilename('OUTPUT ',[rparent]);
support(putpage)
END (*PAGECALL*);
PROCEDURE datecall; (* ASSIGN DATE IN STANDARD DD-MMM-YY FORMAT TO ALFA PARAMETER *)
BEGIN (*DATECALL*)
variable(fsys);
IF comptypes(alfaptr,gattr.typtr) THEN
load←address
ELSE
error(458);
support(asciidate)
END (*DATECALL*);
PROCEDURE timecall; (* ASSIGN TIME IN STANDARD HH:MM:SS FORMAT TO ALFA PARAMETER *)
BEGIN (*TIMECALL*)
variable(fsys);
IF comptypes(alfaptr,gattr.typtr) THEN
load←address
ELSE
error(458);
support(asciitime)
END (*TIMECALL*);
PROCEDURE clockcall; (* RETURN THE ELAPSED CPU-TIME IN MILLISECONDS *)
BEGIN (*CLOCKCALL*)
WITH gattr DO
BEGIN
increment←regc; typtr := intptr; reg := regc; kind := expr;
macro3(047B,regc,30B(*PJOB-UUO*));
macro3(047B,regc,27B(*RUNTIM-UUO*))
END
END (*CLOCKCALL*);
PROCEDURE cardcall; (* RETURN THE CARDINAL NUMBER OF A SET *)
VAR
loop←around: addrrange;
BEGIN (*CARDCALL*)
WITH gattr DO
BEGIN
IF typtr <> NIL THEN
IF typtr↑.form <> power THEN
error(459)
ELSE
BEGIN
increment←regc; increment←regc;
macro3(551B(*HRRZI*),regc,72);
macro2(400B(*SETZ*),regc-1);
loop←around := ic;
macro2(305B(*CAIGE*),gattr.reg - 1);
macro2(340B(*AOJ*),regc-1);
macro3(246B(*LSHC*),gattr.reg - 1,1);
macro3r(367B(*SOJG*),regc,loop←around);
regc := regc - 1;
kind := expr; reg := regc; typtr := intptr
END
END
END (*CARDCALL*);
(* ... ]CALL *)
PROCEDURE abscall; (*RETURN THE ABSOLUTE VALUE OF AN INTEGER OR REAL EXPRESSION*)
BEGIN (*ABSCALL*)
WITH gattr DO
IF (typtr = intptr) OR (typtr = realptr) THEN
IF kind=expr THEN
macro3(214B(*MOVM*),reg,reg)
ELSE
BEGIN
increment←regc;
generate←code(214B(*MOVM*),regc,gattr)
END
ELSE
BEGIN
error(459); typtr:= intptr
END
END (*ABSCALL*) ;
PROCEDURE realtimecall; (* RETURN THE DAY-TIME IN MILLISECONDS *)
BEGIN (*REALTIMECALL*)
WITH gattr DO
BEGIN
increment←regc; typtr := intptr; reg := regc; kind := expr;
macro3(047B,regc,23B(*MSTIME-UUO*))
END
END (*REALTIMECALL*);
PROCEDURE sqrcall; (*RETURN THE SQUARE OF AN INTEGER OR REAL EXPRESSION*)
BEGIN (*SQRCALL*)
WITH gattr DO
IF typtr = intptr THEN
macro3(220B(*IMUL*),reg,reg)
ELSE
IF typtr = realptr THEN
macro3(164B(*FMPR*),reg,reg)
ELSE
BEGIN
error(459); typtr := intptr
END
END (*SQRCALL*) ;
PROCEDURE oddcall; (*RETURN TRUE IF THE INTEGER PARAMETER IS ODD*)
BEGIN (*ODDCALL*)
WITH gattr DO
BEGIN
IF typtr <> intptr THEN
error(459);
macro3(405B(*ANDI*),reg,1);
typtr := boolptr
END
END (*ODDCALL*) ;
PROCEDURE ordcall; (*RETURN THE INTEGER (INTERNAL) VALUE OF A SCALAR*)
BEGIN (*ORDCALL*)
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.form >= power THEN
error(459);
gattr.typtr := intptr
END (*ORDCALL*) ;
PROCEDURE chrcall; (*RETURN THE CHARACTER WHOSE ASCII CODE IS THE PARAMETER*)
BEGIN (*CHR*)
IF gattr.typtr <> intptr THEN
error(459);
gattr.typtr := charptr
END (*CHR*) ;
PROCEDURE predsucc;
VAR
lsp:stp;
pmin,pmax: integer;
BEGIN (*PREDSUCC*)
IF gattr.typtr <> NIL THEN
IF (gattr.typtr↑.form>subrange) OR (gattr.typtr=realptr) THEN
error(459)
ELSE
BEGIN
lsp := gattr.typtr;
IF (lsp↑.form = subrange) THEN
lsp := lsp↑.rangetype;
IF runtime←check AND (lsp <> intptr) THEN
BEGIN
IF lkey=8 THEN
macro3r(365B(*SOJGE*),regc,ic+2)
ELSE
BEGIN
macro2(340B(*AOJ*),regc);
getbounds(lsp,pmin,pmax);
macro3(303B(*CAILE*),regc,pmax)
END;
support(errorinassignment)
END (* RUNTIME←CHECK *)
ELSE
IF lkey = 8 THEN
macro2(360B(*SOJ*),regc)
ELSE
macro2(340B(*AOJ*),regc)
END
END (*PREDSUCC*) ;
PROCEDURE eofeoln; (*RETURN TEH VALUE OF THE EOLN OR EOF FLAG OF THE FILE*)
BEGIN (*EOFEOLN*)
getfilename('INPUT ',[rparent]);
WITH gattr DO
BEGIN
IF lkey=10 THEN
BEGIN
increment←regc; generate←code(332B(*SKIPE*),regc,gattr);
macro3(551B(*HRRZI*),regc,1)
END;
typtr := boolptr
END
END (*EOFEOLN*) ;
PROCEDURE protection;
(* THIS PROCEDURE IS USED BY "PASDDT" TO TEST
IF A PROGRAM'S HIGH-SEGMENT IS SHARED
(WRITE-PROTECTED). PROGRAMS WHICH ARE
TO BE "DEBUGGED" MUST NOT BE SHARABLE.
FOR DETAILS SEE DECSYSTEM-10 "MONITOR-CALLS"
MANUAL, 3.2.4 *)
BEGIN (*PROTECTION*)
expression(fsys, onregc);
IF gattr.typtr = boolptr THEN
BEGIN
load(gattr);
macro3(047B,gattr.reg,36B(*SETUWP-UUO*));
macro3(254B(*HALT*),4,0)
END
ELSE
error(458)
END (*PROTECTION*);
PROCEDURE calltocall;
(* THE STANDARD PROCEDURE
CALL(<FILENAME>[,<DEVICE>[,<PROJECT-PROGRAMMER>[,<CORE-ASSIGNMENT]]])
ALLOWS TO EXIT FROM ONE PROGRAM AND EXECUTE ANOTHER *)
VAR
i:integer;
default:ARRAY[2..4] OF boolean;
PROCEDURE getstringaddress(flength: integer);
BEGIN (*GETSTRINGADDRESS*)
expression(fsys + [comma],onfixedregc);
WITH gattr DO
IF string(typtr) THEN
WITH typtr↑ DO
IF arraypf AND (size = 2) AND ((inxtype↑.vmax.ival-inxtype↑.vmin.ival+1) = flength) THEN
load←address
ELSE
error(458)
ELSE
error(458)
END (*GETSTRINGADDRESS*);
BEGIN (* CALLTOCALL *)
IF NOT external THEN
BEGIN
close←files;
getstringaddress(9);
FOR i := 2 TO 4 DO default[i] := true;
IF sy = comma THEN
BEGIN
insymbol; getstringaddress(6); default[2] := false;
IF sy = comma THEN
BEGIN
insymbol; expression(fsys + [comma],onfixedregc);
IF gattr.typtr = intptr THEN
BEGIN
default[3] := false; load(gattr)
END
ELSE
error(458);
IF sy = comma THEN
BEGIN
insymbol; expression(fsys,onfixedregc);
IF gattr.typtr = intptr THEN
BEGIN
default[4] := false; load(gattr)
END
ELSE
error(458)
END
END
END;
FOR i := 2 TO 4 DO
IF default[i] THEN
BEGIN
increment←regc; macro2(400B(*SETZ*),regc)
END;
support(runprogram);
END
ELSE
error(353)
END (* CALLTOCALL *);
PROCEDURE haltcall; (*THIS PROCEDURE CALLS "PASDDT" IF IT IS LOADED, OTHERWISE IT
EXECUTES A "HALT" INSTRUCTION *)
BEGIN (*HALTCALL*)
macro3(332B(*SKIPE*),reg1,jbddt);
macro4(265B(*JSP*),reg0,reg1,-2);
macro2(254B(*HALT*),4)
END (*HALTCALL*);
PROCEDURE call←non←standard;
VAR
lst,nxt,lnxt,lcp,lcp1: ctp;
lsp: stp;
lkind: idkind; pascalcall:boolean;
save←count,p,i,number←of←parameters: integer;
topp←offset,offset,start←of←parameterlist,actual←parameter,first←parameter,llc: addrrange;
lregc: acrange;
lalfa: alfa;
FUNCTION compparam(fcp1,fcp2 : ctp):boolean;
VAR
ok:boolean;
BEGIN (*COMPPARAM*)
ok:=true;
WHILE ok AND (fcp1<>NIL) AND (fcp2<>NIL) DO WITH fcp1↑ DO
BEGIN
IF comptypes(idtype,fcp2↑.idtype) THEN
IF klass=fcp2↑.klass THEN
IF klass=vars THEN
BEGIN
IF vkind<>fcp2↑.vkind THEN
BEGIN
error(370); ok:=false
END
END
ELSE
ok:=compparam(fparam,fcp2↑.fparam)
ELSE
BEGIN
error(370); ok:=false
END
ELSE
BEGIN
error(370); ok:=false
END;
fcp1:=next; fcp2:=fcp2↑.next
END;
IF fcp1<>fcp2 THEN
BEGIN
error(554); compparam:=false
END
ELSE
compparam:=ok
END(*COMPPARAM*);
(* 25. PASS THE STRING LENGTHS FOR STRING PROCEDURE CALLS.*)
PROCEDURE checksstringcalls;
VAR
i, j: integer;
BEGIN (*CHECKSSTRINGCALLS*);
IF sstringlength <> NIL THEN
IF lst <> NIL THEN
WITH sstringlength↑ DO
BEGIN
j := 1;
FOR i := 1 TO count DO
BEGIN
increment←regc;
macro3(551B(*HRRZI*),regc,value[i]);
IF regc > fcp↑.highest←register THEN
BEGIN
macro4(552B(*HRRZM*),regc,topp,lst↑.vaddr + lst↑.idtype↑.size + j);
regc := fcp↑.highest←register;
j := j + 1;
END;
END;
sstringlength := next;
END;
END (*CHECKSSTRINGCALLS*) (* 25.*);
(* 25. PUT CHARACTER CONSTANTS IN A PLACE IN MEMORY.*)
PROCEDURE charconstant (fchar: char);
VAR
lcsp: csp;
BEGIN (*CHARCONSTANT*)
new(lcsp,strg);
WITH lcsp↑ DO
BEGIN
slgth := 1; sval[1] := fchar;
END;
WITH gattr DO
BEGIN
typtr := packc1ptr;
kind := cst;
cval.valp := lcsp;
END
END (*CHARCONSTANT*);
BEGIN (* CALL←NON←STANDARD *)
number←of←parameters:= 0; topp←offset := 0; start←of←parameterlist := 0;
actual←parameter := 0; lalfa := ' '; lst := NIL; (* 25.*)
pctp := fcp; (* 25.*)
WITH fcp↑ DO
BEGIN
lkind := pfkind;
IF lkind=actual THEN
BEGIN
nxt:=next;
IF externdecl THEN
library[language].called:=true;
pascalcall:=language=pascalsy
END
ELSE
(* LKIND <> ACTUAL *)
BEGIN
nxt:=fparam;
pascalcall:=true
END;
lnxt:=nxt;
IF klass = func THEN
first←parameter := 2
ELSE
first←parameter := 1;
save←count := regc - regin;
IF save←count > 0 THEN
BEGIN
llc := lc ;
lc := lc + save←count ;
IF lc > lcmax THEN
lcmax := lc ;
IF save←count > 3 THEN
BEGIN
macro3(515B(*HRLZI*),reg1,2);
macro4(541B(*HRRI*),reg1,basis,llc);
macro4(251B(*BLT*),reg1,basis,llc+save←count-1)
END
ELSE
FOR i := 1 TO save←count DO macro4(202B(*MOVEM*),regin+i,basis,llc+i-1)
END;
lregc:= regc;
IF lkind=actual THEN
IF language <> pascalsy THEN
regc:= highest←register
ELSE
regc:= regin
ELSE
regc:=regin
END;
IF sy = lparent THEN
BEGIN (* PARAMETERS.*)
parsingparameters := true; (* 25. *)
sstringstart := true; (* 25. *)
REPEAT
recall := false; (* 25.*)
insymbol;
IF nxt=NIL THEN
error(554)
ELSE
IF nxt↑.klass IN [proc,func] THEN
IF sy<>ident THEN
error(209)
ELSE
BEGIN
searchid([proc,func],lcp);
insymbol;
WITH lcp↑ DO
IF pfdeckind=standard THEN
error(510)
ELSE
BEGIN
IF pfkind=actual THEN
lcp1:=next
ELSE
lcp1:=fparam;
IF compparam(nxt↑.fparam,lcp1) THEN
IF nxt↑.klass<>klass THEN
error(503)
ELSE
IF NOT comptypes(idtype,nxt↑.idtype) THEN
error(555)
ELSE
BEGIN
increment←regc;
p:=level-pflev;
IF pfkind=actual THEN
IF language<>pascalsy THEN
error(510)
ELSE
BEGIN
IF p=0 THEN
macro3(514B(*HRLZ*),regc,basis)
ELSE
IF p=1 THEN
macro4(514B(*HRLZ*),regc,basis,-1)
ELSE
IF p>1 THEN
BEGIN
macro4(550B(*HRRZ*),regc,basis,-1);
FOR i:=3 TO p DO macro4(550B(*HRRZ*),regc,regc,-1);
macro4(514B(*HRLZ*),regc,regc,-1)
END;
IF pfaddr=0 THEN
BEGIN
macro3(541B(*HRRI*),regc,linkchain[p]);
linkchain[p]:=ic-1;
IF externdecl THEN
code←reference↑[cix]:=externref
ELSE
code←reference↑[cix]:=forwardref
END
ELSE
macro3r(541B(*HRRI*),regc,pfaddr)
END
ELSE
BEGIN
IF p=0 THEN
macro4(200B(*MOVE*),regc,basis,pfaddr)
ELSE
BEGIN
macro4(200B(*MOVE*),regc,basis,-1);
FOR i:=2 TO p DO
macro4(200B(*MOVE*),regc,regc,-1);
macro4(200B(*MOVE*),regc,regc,pfaddr)
END
END
END
END
END
ELSE
(* NXT↑.KLASS = VARS *)
BEGIN
expression(fsys + [comma,rparent],onfixedregc);
IF gattr.typtr <> NIL THEN
IF nxt <> NIL THEN
BEGIN
lsp := nxt↑.idtype;
IF lsp <> NIL THEN
IF nxt↑.vkind = actual THEN
IF lsp↑.size <= 2 THEN
BEGIN
load(gattr);
IF comptypes(realptr,lsp) THEN
makereal(gattr)
END
ELSE
BEGIN
IF lsp↑.form = files THEN
BEGIN
IF last←file <> NIL THEN
IF last←file↑.name = 'TTY ' THEN
ttyread := true
ELSE
(* 13. REWRITE OUTPUT ONLY IF NEEDED.*)
IF last←file↑.name = 'OUTPUT ' THEN
outputwrite := true
END
ELSE
(* 25. PUT CHARACTER CONSTANTS IN A PLACE IN MEMORY.*)
IF stringpack THEN
IF lsp = sstringptr THEN
WITH gattr DO
IF (typtr↑.bitsize = 7) AND (kind = cst) THEN
charconstant(chr(cval.ival));
load←address;
IF fcp↑.language <> pascalsy THEN
code←array↑.instruction[cix].instr := 515B(*HRLZI*)
END
ELSE
WITH gattr DO
IF kind = varbl THEN
load←address
ELSE
error(463);
IF NOT comptypes(lsp,gattr.typtr) THEN
error(503)
ELSE
(* 25. REJECT NON-SSTRING ON VAR PARAMETERS.*)
IF stringpack THEN
IF lsp = sstringptr THEN
WITH sstringlength↑ DO
IF nxt↑.vkind = formal THEN
BEGIN
IF value[count]
<> xtrastrglgth THEN
error(469);
count := count - 1;
END
ELSE
IF (gattr.typtr↑.form <> arrays) AND (value[count] = 1) THEN
value[count] := xtrastrglgth + 1;
END
END;
IF regc > fcp↑.highest←register THEN
BEGIN
IF topp←offset = 0 THEN
BEGIN
IF fcp↑.pfkind=formal THEN
topp←offset:=fcp↑.parlistsize+1
ELSE
IF fcp↑.language = pascalsy THEN
topp←offset:=fcp↑.parlistsize+1
ELSE
BEGIN
topp←offset := 1 + first←parameter;
REPEAT
WITH lnxt↑ DO
BEGIN
number←of←parameters := number←of←parameters +1;
topp←offset := topp←offset + 1;
IF vkind = actual THEN
IF idtype<>NIL THEN
topp←offset := topp←offset + idtype↑.size;
lnxt := next
END;
UNTIL lnxt = NIL;
start←of←parameterlist := 1 + first←parameter;
actual←parameter := start←of←parameterlist + number←of←parameters
END;
macro3(271B(*ADDI*),topp,topp←offset)
END ;
WITH nxt↑ DO
BEGIN
IF pascalcall THEN
BEGIN
IF klass<>vars THEN
macro4(202B(*MOVEM*),regc,topp,pfaddr+1-topp←offset)
ELSE
IF (idtype↑.size <> 2) OR (vkind = formal) THEN
macro4(202B(*MOVEM*),regc,topp,vaddr+1-topp←offset)
ELSE
BEGIN
macro4(202B(*MOVEM*),regc,topp,vaddr+2-topp←offset);
IF regc>fcp↑.highest←register+1 THEN
macro4(202B(*MOVEM*),regc-1,topp,vaddr+1-topp←offset)
END
END
ELSE
BEGIN
IF klass<>vars THEN
error(468)
ELSE
IF vkind = actual THEN
IF idtype<>NIL THEN
BEGIN
IF idtype↑.size <= 2 THEN
BEGIN
IF idtype↑.size = 2 THEN
BEGIN
macro4(202B(*MOVEM*),regc,topp,actual←parameter+1-topp←offset);
regc := regc - 1
END;
macro4(202B(*MOVEM*),regc,topp,actual←parameter-topp←offset);
macro4(541B(*HRRI*),regc,topp,actual←parameter-topp←offset)
END
ELSE
BEGIN
macro4(541B(*HRRI*),regc,topp,actual←parameter-topp←offset);
macro4(251B(*BLT*),regc,topp,actual←parameter+idtype↑.size-1-topp←offset)
END;
actual←parameter := actual←parameter + idtype↑.size
END;
macro4(552B(*HRRZM*),regc,topp,start←of←parameterlist-topp←offset);
start←of←parameterlist := start←of←parameterlist + 1
END;
regc := fcp↑.highest←register
END
END;
(*REGC>FCP↑.HIGHEST←REGISTER*)
lst := nxt;
IF nxt <> NIL THEN
nxt := nxt↑.next;
skipiferr([comma,rparent],256,fsys)
UNTIL sy <> comma;
parsingparameters := false; (* 25.*)
IF sy = rparent THEN
insymbol
ELSE
error(152)
END (*IF LPARENT*);
IF nxt<>NIL THEN
error(554);
FOR i := 0 TO withix DO
WITH display[top-i] DO
IF (cindr<>0) AND (cindr<>basis) THEN
macro4(202B(*MOVEM*),cindr,basis,clc);
WITH fcp↑ DO
BEGIN
IF lkind=formal THEN
BEGIN
IF topp←offset<>0 THEN
macro3(275B(*SUBI*),topp,topp←offset)
END
ELSE
IF (language = pascalsy) AND (topp←offset <> 0) THEN
macro3(275B(*SUBI*),topp,topp←offset)
ELSE
IF (language <> pascalsy) AND (topp←offset = 0) THEN
BEGIN
topp←offset:= first←parameter+2;
macro3(271B(*ADDI*),topp,topp←offset)
END;
IF pflev > 1 THEN
p := level - pflev
ELSE
p:= 0;
IF lkind = actual THEN
BEGIN
IF language <> pascalsy THEN
BEGIN
macro3(515B(*HRLZI*),reg0,-number←of←parameters);
macro4(202B(*MOVEM*),reg0,topp,first←parameter-topp←offset);
macro4(202B(*MOVEM*),basis,topp,-topp←offset);
macro4(551B(*HRRZI*),basis,topp,first←parameter-topp←offset+1);
IF number←of←parameters = 0 THEN
macro4(402B(*SETZM*),0,topp,first←parameter-topp←offset+1)
END;
IF stringpack THEN
(* 25.*)
checksstringcalls;
IF pfaddr = 0 THEN
BEGIN
macro3r(260B(*PUSHJ*),topp,linkchain[p]); linkchain[p]:= ic-1;
IF externdecl THEN
code←reference↑[cix] := externref
ELSE
code←reference↑[cix] := forwardref
END
ELSE
macro3r(260B(*PUSHJ*),topp,pfaddr-p);
IF language <> pascalsy THEN
BEGIN
macro3(275B(*SUBI*),topp,topp←offset);
IF klass = func THEN
BEGIN
macro4(202B(*MOVEM*),reg0,topp,2);
IF idtype↑.size = 2 THEN
macro4(202B(*MOVEM*),reg1,topp,3)
END;
macro4(200B(*MOVE*),basis,topp,0)
END;
END
ELSE
(*LKIND=FORMAL*)
BEGIN
IF p=0 THEN
BEGIN
macro4(550B(*HRRZ*),reg1,basis,pfaddr);
macro4(544B(*HLR*),basis,basis,pfaddr)
END
ELSE
BEGIN
macro4(550B(*HRRZ*),reg1,basis,-1);
FOR i:=2 TO p DO macro4(550B(*HRRZ*),reg1,reg1,-1);
macro4(544B(*HLR*),basis,reg1,pfaddr);
macro4(550B(*HRRZ*),reg1,reg1,pfaddr)
END;
IF stringpack THEN
(* 25.*)
checksstringcalls;
macro4(260B(*PUSHJ*),topp,reg1,0)
END
END;
FOR i := 0 TO withix DO
WITH display[top-i] DO
IF (cindr<>0) AND (cindr<>basis) THEN
macro4(200B(*MOVE*),cindr,basis,clc) ;
IF save←count > 0 THEN
BEGIN
IF save←count > 3 THEN
BEGIN
macro4(515B(*HRLZI*),reg1,basis,llc);
macro3(541B(*HRRI*),reg1,2);
macro3(251B(*BLT*),reg1,save←count+1)
END
ELSE
FOR i := 1 TO save←count DO macro4(200B(*MOVE*),regin+i,basis,llc+i-1) ;
lc := llc
END ;
gattr.typtr := fcp↑.idtype; regc := lregc
END (*CALL←NON←STANDARD*) ;
BEGIN (*CALL*)
noload := false;
tty←message := false;
buffer←variable := false;
IF fcp↑.pfdeckind = standard THEN
BEGIN (* STANDARD PROCEDURES *)
lkey := fcp↑.key; lclass := fcp↑.klass;
IF fcp↑.klass = proc THEN
BEGIN
IF NOT (lkey IN [1..11,17,19,25..27,29]) THEN
IF sy = lparent THEN
insymbol
ELSE
error(153);
fsys := fsys + [rparent];
IF (lkey IN [5..8,10,11,26..29]) AND (regcmax <= 8) (*<--- REG2..8 USED BY RUNTIME-SUPPORT*) THEN
error(317);
CASE lkey OF
1,2,3,4,
5,6:
getputresetrewrite;
7, 8:
BEGIN
readreadln;
IF no←right←parent THEN
GOTO 666
END;
9:
BEGIN
breakcall ;
IF no←right←parent THEN
GOTO 666
END ;
10, 11:
BEGIN
writewriteln;
IF no←right←parent THEN
GOTO 666
END;
12, 13:
packunpack;
14, 24:
newdispose;
17:
BEGIN
noload := true;
getlinenrcall
END;
19:
BEGIN
pagecall;
IF no←right←parent THEN
GOTO 666
END;
20:
protection;
21:
calltocall;
22:
datecall;
23:
timecall;
25:
BEGIN
haltcall;
GOTO 666
END;
28:
messagecall;
OTHERS:
errandskip(169,fsys)
END
END
ELSE
(* FCP↑.KLAS <> PROC : STANDARD FUNCTIONS *)
BEGIN
IF lkey IN [2..9,13..16,19..22] THEN
BEGIN
IF sy = lparent THEN
insymbol
ELSE
error(153);
IF lkey IN [2..9,13,14,18] THEN
expression(fsys + [rparent,comma],onregc);
IF lkey IN [3..5,8,9,13,14,18] THEN
load(gattr)
END;
CASE lkey OF
1:
realtimecall;
2:
abscall;
3:
sqrcall;
5:
oddcall;
6:
ordcall;
7:
chrcall;
8,9:
predsucc;
10,11:
BEGIN
noload := true;
eofeoln;
IF no←right←parent THEN
GOTO 666
END;
12:
clockcall;
13:
cardcall;
15,16:
lowerupperbound;
19,20:
minmax;
21,22:
firstlast;
OTHERS:
errandskip(169,fsys + [rparent])
END;
IF lkey IN [1,12] THEN
GOTO 666
END;
IF sy = rparent THEN
insymbol
ELSE
error(152);
666:
END (*STANDARD PROCEDURES AND FUNCTIONS*)
ELSE
call←non←standard
END (*CALL*) ;
(* EXPRESSION. *)
PROCEDURE expression; (*(FSYS: SETOFSYS; FVALUE:VALUEKIND)*)
VAR
jump←offset: 2..4;
default←offset: 4..5;
lattr: attr;
lop: operator;
lsize: addrrange;
default,jump: boolean;
boolregc,testregc,lregc1,lregc2:acrange;
linstr,linstr1: instrange;
setinclusion : boolean;
jmpadrifallequal : integer;
PROCEDURE changebool(VAR finstr: instrange);
BEGIN (*CHANGEBOOL*)
IF (finstr>=311B) AND (finstr<=313B) THEN
finstr := finstr+4 (*CAML,CAME,CAMLE --> CAMGE,CAMN,CAMG*)
ELSE
IF (finstr>=315B) AND (finstr<=317B) THEN
finstr := finstr-4 (*SAME IN THE OTHER WAY*)
END (*CHANGEBOOL*);
PROCEDURE searchcode(finstr:instrange; fattr: attr);
PROCEDURE changeoperands(VAR finstr:instrange);
BEGIN (*CHANGEOPERANDS*)
IF finstr=311B(*CAML*) THEN
finstr := 317B(*CAMG*)
ELSE
IF finstr = 313B(*CAMLE*) THEN
finstr := 315B(*CAMGE*)
ELSE
IF finstr=315B(*CAMGE*) THEN
finstr := 313B(*CAMLE*)
ELSE
IF finstr = 317B(*CAMG*) THEN
finstr := 311B(*CAML*)
ELSE
IF finstr = 420B(*ANDCM*) THEN
finstr := 410B(*ANDCA*)
ELSE
IF finstr = 410B(*ANDCA*) THEN
finstr := 420B(*ANDCM*)
END (*CHANGEOPERANDS*);
BEGIN (*SEARCHCODE*)
WITH gattr DO
IF fattr.kind = expr THEN
BEGIN
generate←code(finstr,fattr.reg,gattr); reg := fattr.reg
END
ELSE
IF kind = expr THEN
BEGIN
changeoperands(finstr); generate←code(finstr,reg,fattr)
END
ELSE
IF (kind=varbl) AND ((packfg<>notpack)
OR (indexr>regin) AND (indexr<=regcmax) AND
((fattr.indexr<=regin) OR (fattr.indexr>regcmax))) THEN
BEGIN
load(gattr); changeoperands(finstr); generate←code(finstr,reg,fattr)
END
ELSE
BEGIN
load(fattr); generate←code(finstr,fattr.reg,gattr); reg := fattr.reg
END
END (*SEARCHCODE*);
PROCEDURE simpleexpression(fsys: setofsys);
VAR
lattr: attr; lop: operator; signed : boolean;
PROCEDURE term(fsys: setofsys);
VAR
lattr: attr; lop: operator;
PROCEDURE factor(fsys: setofsys);
VAR
lcp: ctp; lvp: csp; varpart: boolean;
cstpart: SET OF setrange; lsp: stp;
rangepart: boolean; lrmin: setrange;
loffset: 0..offset ;
BEGIN (*FACTOR*)
IF NOT (sy IN facbegsys) THEN
BEGIN
errandskip(173,fsys + facbegsys);
gattr.typtr := NIL
END;
IF sy IN facbegsys THEN
BEGIN
CASE sy OF
ident:
BEGIN
searchid([konst,vars,field,func],lcp);
insymbol;
CASE lcp↑.klass OF
func:
BEGIN
call(fsys,lcp);
IF lcp↑.pfdeckind=declared THEN
BEGIN
WITH lcp↑,gattr DO
BEGIN
typtr :=idtype; kind :=varbl; packfg :=notpack;
vrelbyte := no;
vlevel :=1; dplmt :=2;
indexr := topp; indbit :=0;
IF typtr <> NIL THEN
IF typtr↑.size = 1 THEN
load(gattr)
END
END
END;
konst:
WITH gattr, lcp↑ DO
BEGIN
typtr := idtype; kind := cst;
cval := values
END;
OTHERS:
selector(fsys,lcp)
END (*CASE KLASS*);
IF gattr.typtr <> NIL THEN
WITH gattr, typtr↑ DO
IF form = subrange (*ELIMINATE SUBRANGE TYPES*) THEN
typtr := rangetype (*TO SIMPLIFY LATER TESTS*)
END;
intconst:
BEGIN
WITH gattr DO
BEGIN
typtr := intptr; kind := cst;
cval := val
END;
insymbol
END;
realconst:
BEGIN
WITH gattr DO
BEGIN
typtr := realptr; kind := cst;
cval := val
END;
insymbol
END;
stringconst:
BEGIN
WITH gattr DO
BEGIN
constant(fsys,typtr,cval) ; kind := cst
END
END;
lparent:
BEGIN
insymbol; expression(fsys + [rparent],onregc);
IF sy = rparent THEN
insymbol
ELSE
error(152)
END;
notsy:
BEGIN
insymbol; factor(fsys);
IF gattr.typtr = boolptr THEN
BEGIN
load(gattr); macro3(411B(*ANDCAI*),regc,1)
END
ELSE
BEGIN
error(359); gattr.typtr := NIL
END
END;
lbrack:
BEGIN
insymbol; cstpart := [ ]; varpart := false;
rangepart:=false;
new(lsp,power);
WITH lsp↑ DO
BEGIN
elset:=NIL; size:= 2
END;
IF sy = rbrack THEN
BEGIN
WITH gattr DO
BEGIN
typtr:=lsp; kind:=cst;
new(lvp,pset); lvp↑.pval := cstpart; cval.valp := lvp
END;
insymbol
END
ELSE
BEGIN
LOOP
increment←regc; increment←regc;
expression(fsys + [comma,rbrack,colon],onregc);
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.form <> scalar THEN
BEGIN
error(461); gattr.typtr := NIL
END
ELSE
IF comptypes(lsp↑.elset,gattr.typtr) THEN
WITH gattr DO
BEGIN
IF kind = cst THEN
BEGIN
IF comptypes(typtr,asciiptr) THEN
cval.ival := cval.ival-offset;
IF (cval.ival < 0) OR (cval.ival > basemax) THEN
error(268)
ELSE
cstpart := cstpart + [cval.ival];
regc := regc - 2;
IF sy=colon THEN
BEGIN
rangepart:=true;
lrmin:=cval.ival
END
ELSE
IF rangepart THEN
BEGIN
lrmin:=lrmin+1;
WHILE (lrmin<cval.ival) DO
BEGIN
cstpart:=cstpart + [lrmin];
lrmin:=lrmin+1
END;
rangepart:=false
END
END
ELSE
BEGIN
IF (sy=colon) OR rangepart THEN
BEGIN
error(207);rangepart := NOT rangepart
END;
load(gattr);
regc := regc -1;
macro3(515B(*HRLZI*),regc-1,400000B);
macro2(400B(*SETZ*),regc);
IF runtime←check THEN
BEGIN
IF comptypes(typtr,asciiptr) THEN
loffset := offset
ELSE
loffset := 0 ;
macro3(301B(*CAIL*),regc+1,loffset);
macro3(303B(*CAILE*),regc+1,basemax+loffset);
support(errorinset)
END;
macro3(210B(*MOVN*),regc+1,regc+1);
IF comptypes(typtr,asciiptr) THEN
macro4(246B(*LSHC*),regc-1,regc+1,offset)
ELSE
macro4(246B(*LSHC*),regc-1,regc+1,0);
IF varpart THEN
BEGIN
macro3(434B(*IOR*),regc-3,regc-1);
macro3(434B(*IOR*),regc-2,regc);
regc := regc - 2
END
ELSE
varpart := true;
kind := expr; reg := regc
END;
lsp↑.elset := typtr;
typtr :=lsp
END
ELSE
error(360)
EXIT IF NOT(sy IN [comma,colon]);
insymbol
END;
IF sy = rbrack THEN
insymbol
ELSE
error(155);
IF varpart THEN
BEGIN
IF cstpart <> [ ] THEN
BEGIN
new(lvp,pset); lvp↑.pval := cstpart;
gattr.kind := cst; gattr.cval.valp := lvp;
generate←code(434B(*IOR*),regc,gattr)
END
END
ELSE
BEGIN
new(lvp,pset); lvp↑.pval := cstpart; gattr.cval.valp := lvp
END
END
END
END (*CASE*) ;
iferrskip(166,fsys)
END (*IF SY IN FACBEGSYS*)
END (*FACTOR*) ;
BEGIN (*TERM*)
factor(fsys + [mulop]);
WHILE sy = mulop DO
BEGIN
IF op IN [rdiv,idiv,imod] THEN
load(gattr);
(*BECAUSE OPERANDS ARE NOT
ALLOWED TO BE CHOSEN*)
lattr := gattr; lop := op;
insymbol; factor(fsys + [mulop]);
IF (lattr.typtr <> NIL) AND (gattr.typtr <> NIL) THEN
CASE lop OF
mul:
IF comptypes(lattr.typtr,gattr.typtr)
AND (gattr.typtr↑.form = power) THEN
searchcode(404B(*AND*),lattr)
ELSE
IF (lattr.typtr = intptr) AND (gattr.typtr = intptr) THEN
searchcode(220B(*IMUL*),lattr)
ELSE
BEGIN
makereal(lattr);
IF (lattr.typtr = realptr) AND (gattr.typtr = realptr) THEN
searchcode(164B(*FMPR*),lattr)
ELSE
BEGIN
error(311); gattr.typtr := NIL
END
END;
rdiv:
BEGIN
makereal(lattr);
IF (lattr.typtr = realptr) AND (gattr.typtr = realptr) THEN
searchcode(174B(*FDVR*),lattr)
ELSE
BEGIN
error(311); gattr.typtr := NIL
END
END;
idiv:
IF (lattr.typtr = intptr) AND (gattr.typtr = intptr) THEN
searchcode(230B(*IDIV*),lattr)
ELSE
BEGIN
error(311); gattr.typtr := NIL
END;
imod:
IF (lattr.typtr = intptr) AND (gattr.typtr = intptr) THEN
BEGIN
searchcode(230B(*IDIV*),lattr);gattr.reg := gattr.reg+1
END
ELSE
BEGIN
error(311); gattr.typtr := NIL
END;
andop:
IF comptypes(lattr.typtr,gattr.typtr)
AND (gattr.typtr = boolptr) THEN
searchcode(404B(*AND*),lattr)
ELSE
BEGIN
error(311); gattr.typtr := NIL
END
END (*CASE*)
ELSE
gattr.typtr := NIL;
regc:=gattr.reg
END (*WHILE*)
END (*TERM*) ;
BEGIN (*SIMPLEEXPRESSION*)
signed := false;
IF (sy = addop) AND (op IN [plus,minus]) THEN
BEGIN
signed := op = minus; insymbol
END;
term(fsys + [addop]);
IF signed THEN
WITH gattr DO
IF typtr <> NIL THEN
IF (typtr = intptr) OR (typtr = realptr) THEN
CASE kind OF
cst:
IF typtr = intptr THEN
cval.ival := - cval.ival
ELSE
BEGIN
increment←regc;
generate←code(210B(*MOVN*),regc,gattr)
END;
varbl:
BEGIN
increment←regc;
generate←code(210B(*MOVN*),regc,gattr)
END;
expr:
macro3(210B(*MOVN*),reg,reg)
END (*CASE*)
ELSE
BEGIN
error(311) ; gattr.typtr := NIL
END ;
WHILE sy = addop DO
BEGIN
IF aos = b2 THEN
IF (leftside.packfg=notpack) AND comptypes(leftside.typtr,intptr) THEN
BEGIN
leftside.typtr:=intptr; leftside.bpaddr:=gattr.bpaddr;
IF leftside=gattr THEN
aos := b3
ELSE
aos:=b0
END
ELSE
aos := b0
ELSE
aos := b0;
IF op=minus THEN
load(gattr);
(*BECAUSE OPD MAY NOT BE CHOSEN*)
lattr := gattr; lop := op;
insymbol; term(fsys + [addop]);
IF aos=b3 THEN
IF gattr.kind<>cst THEN
aos:=b0;
IF (lattr.typtr <> NIL) AND (gattr.typtr <> NIL) THEN
CASE lop OF
plus:
IF comptypes(lattr.typtr,gattr.typtr)
AND (gattr.typtr↑.form = power) THEN
searchcode(434B(*IOR*),lattr)
ELSE
IF (lattr.typtr = intptr) AND (gattr.typtr = intptr) THEN
BEGIN
IF aos=b3 THEN
IF gattr.cval.ival=1 THEN
aos := aosinstr;
searchcode(270B(*ADD*),lattr)
END
ELSE
BEGIN
makereal(lattr);
IF (lattr.typtr=realptr) AND (gattr.typtr=realptr) THEN
searchcode(144B(*FADR*),lattr)
ELSE
BEGIN
error(311); gattr.typtr := NIL
END
END;
minus:
IF (lattr.typtr=intptr) AND (gattr.typtr=intptr) THEN
BEGIN
IF aos=b3 THEN
IF gattr.cval.ival=1 THEN
aos := sosinstr;
searchcode(274B(*SUB*),lattr)
END
ELSE
BEGIN
makereal(lattr);
IF (lattr.typtr = realptr) AND (gattr.typtr = realptr) THEN
searchcode(154B(*FSBR*),lattr)
ELSE
IF comptypes(lattr.typtr,gattr.typtr)
AND (lattr.typtr↑.form = power) THEN
searchcode(420B(*ANDCM*),lattr)
ELSE
BEGIN
error(311); gattr.typtr := NIL
END
END;
orop:
IF comptypes(lattr.typtr,gattr.typtr)
AND (gattr.typtr = boolptr) THEN
searchcode(434B(*IOR*),lattr)
ELSE
BEGIN
error(311); gattr.typtr := NIL
END
END (*CASE*)
ELSE
gattr.typtr := NIL;
regc:=gattr.reg;
IF aos <= b3 THEN
aos := b0
END (*WHILE*);
IF aos <= b3 THEN
aos := b0
END (*SIMPLEEXPRESSION*) ;
BEGIN (*EXPRESSION*)
testregc := regc+1;
IF aos=b1 THEN
aos:=b2
ELSE
aos:=b0;
simpleexpression(fsys + [relop]);
IF sy = relop THEN
BEGIN
jump := false;
IF fvalue IN [onregc,onfixedregc] THEN
BEGIN
increment←regc; macro3(551B(*HRRZI*),regc,1); boolregc := regc
END;
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.size > 2 THEN
load←address;
lregc1 := regc;
lattr := gattr;
lop := op;
IF (fvalue IN [onregc,onfixedregc]) AND (regc < boolregc) THEN
regc := boolregc;
insymbol; simpleexpression(fsys);
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.size > 2 THEN
load←address;
lregc2 := regc;
IF (lattr.typtr <> NIL) AND (gattr.typtr <> NIL) THEN
BEGIN
IF lop = inop THEN
IF gattr.typtr↑.form = power THEN
IF comptypes(lattr.typtr,gattr.typtr↑.elset) THEN
BEGIN
load(lattr);
IF (fvalue IN [onregc,onfixedregc]) AND (regc < boolregc) THEN
regc := boolregc;
load(gattr); regc := gattr.reg - 1;
IF comptypes(lattr.typtr,asciiptr) THEN
macro4(246B(*LSHC*),regc,lattr.reg,-offset)
ELSE
macro4(246B(*LSHC*),regc,lattr.reg,0);
IF fvalue = truejmp THEN
linstr := 305B(*CAIGE*)
ELSE
linstr := 301B(*CAIL*);
macro2(linstr,regc)
END
ELSE
BEGIN
error(260); gattr.typtr := NIL
END
ELSE
BEGIN
error(213); gattr.typtr := NIL
END
ELSE
BEGIN
IF lattr.typtr <> gattr.typtr THEN
makereal(lattr);
IF comptypes(lattr.typtr,gattr.typtr) THEN
BEGIN
lsize := lattr.typtr↑.size;
CASE lattr.typtr↑.form OF
power:
IF lop IN [ltop,gtop] THEN
error(313);
arrays:
IF NOT string(lattr.typtr)
AND (lop IN [ltop,leop,gtop,geop]) THEN
error(312);
pointer,
records:
IF lop IN [ltop,leop,gtop,geop] THEN
error(312);
files:
error(314)
END;
WITH lattr.typtr↑ DO
BEGIN
IF size <= 2 THEN
BEGIN
default := true;
setinclusion := false;
jump←offset := 3;
default←offset := 4;
CASE lop OF
ltop:
BEGIN
linstr := 311B(*CAML*); linstr1 := 313B
END;
leop:
IF form = power THEN
BEGIN
searchcode(420B(*ANDCM*),lattr);
setinclusion := true
END
ELSE
BEGIN
linstr := 313B(*CAMLE*); linstr1 := 313B
END;
gtop:
BEGIN
linstr := 317B(*CAMG*); linstr1 := 315B
END;
geop:
IF form = power THEN
BEGIN
searchcode(410B(*ANDCA*),lattr);
setinclusion := true
END
ELSE
BEGIN
linstr := 315B(*CAMGE*); linstr1 := 315B
END;
neop:
BEGIN
linstr := 316B(*CAMN*);default := false
END;
eqop:
BEGIN
linstr := 312B(*CAME*); default := false
END
END;
IF fvalue IN [truejmp,falsejmp] THEN
BEGIN
IF (form = scalar) AND (gattr.kind = cst) THEN
IF lattr.typtr = realptr THEN
jump := gattr.cval.valp↑.rval = 0.0
ELSE
IF gattr.cval.ival = 0 THEN
jump := true;
IF (fvalue = truejmp) <> jump THEN
changebool(linstr);
IF jump THEN
linstr := linstr + 10B (*E.G CAML --> JUMPL *)
END;
IF size = 1 THEN
IF jump THEN
BEGIN
load(lattr); macro3(linstr,lattr.reg,0)
END
ELSE
searchcode(linstr,lattr)
ELSE
IF setinclusion THEN
BEGIN
macro3(336B(*SKIPN*),0,gattr.reg);
macro3(332B(*SKIPE*),0,gattr.reg-1);
IF fvalue = truejmp THEN
macro3r(254B(*JRST*),0,ic+2)
END
ELSE
BEGIN
load(lattr);
IF (fvalue IN [onregc,onfixedregc]) AND (regc<boolregc) THEN
regc := boolregc;
load(gattr);
CASE fvalue OF
onregc,
onfixedregc,
falsejmp:
IF lop = eqop THEN
jump←offset := 2;
truejmp:
IF lop <> eqop THEN
BEGIN
jump←offset := 2; default←offset := 5
END
END;
IF default THEN
BEGIN
macro3(linstr1,lattr.reg-1,gattr.reg-1);
macro3r(254B(*JRST*),0,ic + default←offset)
END;
macro3(312B(*CAME*),lattr.reg-1,gattr.reg-1);
macro3r(254B(*JRST*),0,ic+jump←offset);
macro3(linstr,lattr.reg,gattr.reg)
END
END
ELSE
BEGIN
macro3(551B(*HRRZI*),reg0,lsize);
increment←regc ;
macro4(200B(*MOVE*),regc,lregc1,0);
macro4(312B(*CAME*),regc,lregc2,0);
macro3r(254B(*JRST*),0,ic+5);
macro2(340B(*AOJ*),lregc1);
macro2(340B(*AOJ*),lregc2);
macro3r(367B(*SOJG*),reg0,ic-5);
jmpadrifallequal := 0;
CASE lop OF
ltop,gtop:
IF fvalue=truejmp THEN
jmpadrifallequal := 3
ELSE
jmpadrifallequal := 2;
leop,geop:
IF fvalue=truejmp THEN
jmpadrifallequal := 2
ELSE
jmpadrifallequal := 3;
eqop :
IF fvalue<>truejmp THEN
jmpadrifallequal := 2;
neop :
IF fvalue=truejmp THEN
jmpadrifallequal := 2
END;
IF jmpadrifallequal <> 0 THEN
macro4r(254B(*JRST*),0,0,ic+jmpadrifallequal);
CASE lop OF
ltop,leop:
linstr := 311B(*CAML*);
gtop,geop:
linstr := 317B(*CAMG*)
END;
IF fvalue=truejmp THEN
changebool(linstr);
IF lop IN [ltop,leop,gtop,geop] THEN
macro4(linstr,regc,lregc2,0);
regc:=regc-2
END
END
END
ELSE
error(260)
END;
IF fvalue IN [onregc,onfixedregc] THEN
BEGIN
macro3(400B(*SETZ*),boolregc,0); regc := boolregc
END
ELSE
IF NOT jump THEN
macro3(254B(*JRST*),0,0)
END;
gattr.typtr := boolptr; gattr.kind := expr; gattr.reg := regc
END (*SY = RELOP*)
ELSE
IF fvalue IN [truejmp,falsejmp] THEN
BEGIN
load(gattr);
IF gattr.typtr<>boolptr THEN
error (359);
IF fvalue = truejmp THEN
linstr := 326B(*JUMPN*)
ELSE
linstr := 322B(*JUMPE*);
macro3(linstr,gattr.reg,0)
END
ELSE
IF gattr.kind=expr THEN
regc := gattr.reg;
IF fvalue = onfixedregc THEN
WITH gattr DO
IF (typtr <> NIL) AND (kind=expr) THEN
WITH typtr↑ DO
BEGIN
IF size = 2 THEN
testregc := testregc + 1;
IF testregc <> regc THEN
BEGIN
IF size = 2 THEN
macro3(200B(*MOVE*),testregc-1,regc-1);
macro3(200B(*MOVE*),testregc,regc); regc := testregc;reg := regc
END
END
END (*EXPRESSION*) ;
(* PARSING OF THE STATEMETS. *)
PROCEDURE assignment(fcp: ctp);
VAR
slattr: attr;
cmin, cmax: valu;
leftside←real: boolean;
linstr: instrange;
oldix: coderange;
oldic: addrrange;
PROCEDURE storeglobals ;
TYPE
changeform = (ptrw,intw,reelw,psetw,strgw,instw) ;
VAR
change : RECORD
CASE kw : changeform OF
ptrw: (wptr :gtp (*TO ALLOW NIL*)) ;
intw: (wint : integer ; wint1 : integer (*TO PICK UP SECOND WORD OF SET*)) ;
reelw: (wreel: real) ;
psetw: (wset : SET OF setrange) ;
strgw: (wstrg: charword) ;
instw: (winst: pdp10instr)
END ;
i: 1..strglgth; j: 0..5;
PROCEDURE storeword ;
BEGIN (*STOREWORD*)
cix := cix + 1 ;
IF cix > code←size THEN
BEGIN
cix := 0;
IF NOT overrun THEN
BEGIN
overrun := true;
error←with←text(356,'INITPROCD.')
END
END ;
WITH cglobptr↑ DO
BEGIN
code←array↑.instruction[cix] := change.winst ;
lastglob := lastglob + 1
END
END (*STOREWORD*) ;
PROCEDURE getnewglobptr ;
VAR
lglobptr : gtp ;
BEGIN (*GETNEWGLOBPTR*)
new(lglobptr) ;
WITH lglobptr↑ DO
BEGIN
nextglobptr := NIL ;
firstglob := 0
END ;
IF cglobptr <> NIL THEN
cglobptr↑.nextglobptr := lglobptr ;
cglobptr := lglobptr
END (*GETNEWGLOBPTR*);
BEGIN
(*STOREGLOBALS*)
IF fglobptr = NIL THEN
BEGIN
getnewglobptr ;
fglobptr := cglobptr
END
ELSE
IF leftside.dplmt <> cglobptr↑.lastglob + 1 THEN
getnewglobptr ;
WITH change,cglobptr↑,gattr,cval DO
BEGIN
IF firstglob = 0 THEN
BEGIN
IF leftside.packfg<>notpack THEN
IF errlist[errinx].arw<>507 THEN
error(507);
firstglob := leftside.dplmt ;
lastglob := firstglob - 1 ;
fcix := cix + 1
END ;
CASE typtr↑.form OF
scalar,
subrange:
BEGIN
IF leftside←real THEN
IF typtr=intptr THEN
wreel := ival
ELSE
wreel := valp↑.rval
ELSE
wint := ival ;
storeword
END ;
pointer :
BEGIN
wptr := NIL ; storeword
END ;
power :
BEGIN
wset := valp↑.pval ; storeword ;
wint := wint1 (*GET SECOND WORD OF SET*) ;
storeword
END ;
arrays :
WITH valp↑,change DO
BEGIN
j := 0; wint := 0;
FOR i := 1 TO slgth DO
BEGIN
j := j + 1;
wstrg[j] := sval[i];
IF j=5 THEN
BEGIN
j := 0;
storeword; wint := 0
END
END;
IF j<>0 THEN
storeword
END;
OTHERS :
error(411)
END (*CASE*)
END (* WITH *)
END (* STOREGLOBALS *) ;
BEGIN (*ASSIGNMENT*)
selector(fsys + [becomes],fcp);
IF sy = becomes THEN
BEGIN
leftside := gattr;
leftside←real := comptypes(leftside.typtr,realptr);
IF NOT runtime←check THEN
BEGIN
aos := b1; oldix:=cix; oldic:=ic
END;
insymbol;
expression(fsys,onregc);
IF (leftside.typtr <> NIL) AND (gattr.typtr <> NIL) THEN
IF comptypes(leftside.typtr,gattr.typtr) OR
leftside←real AND (gattr.typtr=intptr) THEN
IF initglobals THEN
IF gattr.kind = cst THEN
storeglobals
ELSE
error(504)
ELSE
IF (gattr.kind=cst) AND (gattr.cval.ival=0) AND
(leftside.packfg<>packk) THEN
WITH leftside DO
BEGIN
fetch←basis(leftside);
WITH typtr↑ DO
IF form = subrange THEN
IF leftside←real THEN
BEGIN
IF (vmin.valp↑.rval > 0) OR (vmax.valp↑.rval < 0) THEN
error(367)
END
ELSE
IF (vmin.ival > 0) OR (vmax.ival < 0) THEN
error(367) ;
CASE packfg OF
notpack:
linstr := 402B(*SETZM*);
hwordl:
linstr := 553B(*HRRZS*);
hwordr:
linstr := 513B(*HLLZS*)
END (*CASE*);
macro(vrelbyte,linstr,0,indbit,indexr,dplmt)
END
ELSE
IF aos >= aosinstr THEN
BEGIN
ic := oldic; cix := oldix;
IF aos=aosinstr THEN
generate←code(350B(*AOS*),0,leftside)
ELSE
generate←code(370B(*SOS*),0,leftside)
END
ELSE
CASE leftside.typtr↑.form OF
scalar,
pointer,
power:
BEGIN
load(gattr);
IF (gattr.typtr=intptr) AND leftside←real THEN
makereal(gattr);
store(gattr.reg,leftside)
END;
subrange:
BEGIN
cmin := leftside.typtr↑.vmin;
cmax := leftside.typtr↑.vmax;
IF leftside←real THEN
IF gattr.typtr=intptr THEN
makereal(gattr);
IF gattr.kind = cst THEN
WITH gattr DO
BEGIN
IF leftside←real THEN
BEGIN
IF (cval.valp↑.rval < cmin.valp↑.rval)
OR (cval.valp↑.rval > cmax.valp↑.rval) THEN
error(367)
END (*LEFTSIDE←REAL*)
ELSE
IF (cval.ival < cmin.ival) OR (cval.ival > cmax.ival) THEN
error (367);
load(gattr)
END (*=CST*)
ELSE
IF runtime←check AND ((gattr.kind<>varbl) OR (gattr.subkind <> leftside.typtr)) THEN
BEGIN
load(gattr);
WITH slattr DO
BEGIN
typtr:= gattr.typtr;
kind := cst;
cval := cmax
END;
generate←code(317B(*CAMG*),regc,slattr);
slattr.kind:=cst;
slattr.cval:=cmin;
generate←code(315B(*CAMGE*),regc,slattr);
support(errorinassignment)
END (*RUNTIMECHECK*)
ELSE
load(gattr);
store(gattr.reg,leftside)
END;
arrays,
records:
IF gattr.typtr↑.size = 1 THEN
BEGIN
load(gattr) ; store(gattr.reg,leftside)
END
ELSE
WITH leftside DO
BEGIN
load←address ;
code←array↑.instruction[cix].instr := 515B(*HRLZI*) ;
fetch←basis(leftside);
macro(vrelbyte,541B(*HRRI*),regc,indbit,indexr,dplmt);
IF indbit=0 THEN
macro5(vrelbyte,251B(*BLT *),regc,indexr,dplmt+typtr↑.size-1)
ELSE
BEGIN
increment←regc ;
macro3(200B(*MOVE*),regc,regc-1);
macro4(251B(*BLT *),regc,regc-1,typtr↑.size-1)
END
END;
files:
error(361)
END (*CASE*)
ELSE
(* NOT COMPTYPES ... *)
error(260);
aos := b0
END (*SY = BECOMES*)
ELSE
error(159)
END (*ASSIGNMENT*) ;
PROCEDURE gotostatement;
VAR
lcp: ctp; lscope: levrange;
BEGIN (*GOTOSTATEMENT*)
IF sy = intconst THEN
BEGIN
searchid([labels],lcp);
IF lcp <> NIL THEN
WITH lcp↑ DO
BEGIN
lscope := level - scope;
macro3r(254B(*JRST*),0,goto←chain);
goto←chain := ic-1; code←reference↑[cix] := gotoref;
IF lscope > 0 THEN
IF (scope = 1) AND external THEN
error(508)
ELSE
exit←jump := true
END;
insymbol
END
ELSE
error(255)
END (*GOTOSTATEMENT*) ;
PROCEDURE compoundstatement;
BEGIN (*COMPOUNDSTATEMENT*)
LOOP
REPEAT
statement(fsys,statends)
UNTIL NOT (sy IN statbegsys)
EXIT IF sy <> semicolon;
insymbol
END;
IF sy = endsy THEN
insymbol
ELSE
error(163)
END (*COMPOUNDSTATEMENET*) ;
PROCEDURE ifstatement;
VAR
lcix1,lcix2: coderange;
BEGIN (*IFSTATEMENT*)
expression(fsys + [thensy],falsejmp);
lcix1 := cix;
IF sy = thensy THEN
insymbol
ELSE
error(164);
statement(fsys + [elsesy],statends + [elsesy]);
IF sy = elsesy THEN
BEGIN
macro3(254B(*JRST*),0,0); lcix2 := cix;
insert←address(right,lcix1,ic);
insymbol; statement(fsys,statends);
insert←address(right,lcix2,ic)
END
ELSE
insert←address(right,lcix1,ic)
END (*IFSTATEMENT*) ;
PROCEDURE casestatement;
LABEL
888,999;
TYPE
cip = ↑caseinfo;
caseinfo = PACKED
RECORD
next: cip;
csstart: addrrange;
csend: coderange;
cslab: integer
END;
VAR
lsp, lsp1: stp;
fstptr, lpt1, lpt2, lpt3, othersptr: cip;
lval: valu;
lic, laddr, jumpaddr, lmin, lmax: addrrange;
lcix: coderange;
PROCEDURE insertbound(fcix: coderange; fic: addrrange; bound: integer);
VAR
lcix1:coderange;
lic1: addrrange;
lattr:attr;
BEGIN (*INSERTBOUND*)
IF bound >= 0 THEN
insert←address(no,fcix,bound)
ELSE
BEGIN
lcix1:=cix; lic1 := ic;
cix:=fcix; ic := fic;
WITH lattr DO
BEGIN
kind:=cst;
cval.ival:=bound;
typtr:=NIL
END;
deposit←constant(int,lattr);
cix:=lcix1; ic:= lic1;
WITH code←array↑.instruction[fcix] DO
instr:=instr+10B (*CAILE-->CAMLE, CAIL-->CAML*)
END
END (*INSERTBOUND*);
BEGIN (*CASESTATEMENT*)
othersptr:=NIL;
expression(fsys + [ofsy,comma,colon],onregc);
load(gattr);
macro2(301B(*CAIL*),regc); (*<<<---- LMIN IS INSERTED HERE*)
macro2(303B(*CAILE*),regc); (*<<<---- LMAX IS INSERTED HERE*)
macro2(254B(*JRST*),0); (*<<<---- START OF "OTHERS" IS INSERTED HERE*)
macro(no,254B(*JRST*),0,1,regc,0);(*<<<---- START OF JUMP TABLE IS INSERTED HERE*)
lcix := cix; lic := ic;
lsp := gattr.typtr;
IF lsp <> NIL THEN
IF (lsp↑.form <> scalar) OR (lsp = realptr) THEN
BEGIN
error(315); lsp := NIL
END;
IF sy = ofsy THEN
insymbol
ELSE
error(160);
(* 13. ALLOW EXTRA SEMICOLONS.*)
WHILE sy = semicolon DO
insymbol;
fstptr := NIL; lpt3 := NIL;
LOOP
LOOP
constant(fsys + [comma,colon],lsp1,lval);
IF lsp <> NIL THEN
IF comptypes(lsp,lsp1) THEN
BEGIN
lpt1 := fstptr; lpt2 := NIL;
IF abs(lval.ival) > hwcstmax THEN
error(316);
WHILE lpt1 <> NIL DO
WITH lpt1↑ DO
BEGIN
IF cslab <= lval.ival THEN
BEGIN
IF cslab = lval.ival THEN
error(261);
GOTO 888
END;
lpt2 := lpt1; lpt1 := next
END;
888:
new(lpt3);
WITH lpt3↑ DO
BEGIN
next := lpt1; cslab := lval.ival;
csstart := ic; csend := 0
END;
IF lpt2 = NIL THEN
fstptr := lpt3
ELSE
lpt2↑.next := lpt3
END
ELSE
error(505)
EXIT IF sy <> comma;
insymbol
END;
IF sy = colon THEN
insymbol
ELSE
error(151);
REPEAT
statement(fsys,statends)
UNTIL NOT (sy IN statbegsys);
IF lpt3 <> NIL THEN
BEGIN
macro2(254B(*JRST*),0); lpt3↑.csend := cix
END;
(* 13. ALLOW EXTRA SEMICOLONS.*)
WHILE sy = semicolon DO
insymbol;
EXIT IF sy IN (fsys + statends);
IF sy=otherssy THEN
BEGIN
insymbol;
IF sy=colon THEN
insymbol
ELSE
error(151);
new(othersptr);
WITH othersptr↑ DO
BEGIN
csstart:=ic;
REPEAT
statement(fsys,statends)
UNTIL NOT(sy IN statbegsys);
macro2(254B(*JRST*),0);
csend:=cix;
(* 13. ALLOW EXTRA SEMICOLONS *)
WHILE sy = semicolon DO
insymbol;
GOTO 999
END
END
END;
999:
IF fstptr <> NIL THEN
BEGIN
lmax := fstptr↑.cslab;
(*REVERSE POINTERS*)
lpt1 := fstptr; fstptr := NIL;
REPEAT
lpt2 := lpt1↑.next; lpt1↑.next := fstptr;
fstptr := lpt1; lpt1 := lpt2
UNTIL lpt1 = NIL;
lmin := fstptr↑.cslab;
insertbound(lcix-2,lic-2,lmax);
insertbound(lcix-3,lic-3,lmin);
insert←address(right,lcix,ic-lmin);
IF (lmax - lmin) < (code←size - cix) THEN
BEGIN
laddr := ic + lmax - lmin + 1;
IF othersptr = NIL THEN
jumpaddr := laddr
ELSE
BEGIN
insert←address(right,othersptr↑.csend,laddr);
jumpaddr:=othersptr↑.csstart
END;
insert←address(right,lcix-1,jumpaddr);
REPEAT
WITH fstptr↑ DO
BEGIN
WHILE cslab > lmin DO
BEGIN
generate←word(right,0,jumpaddr); lmin := lmin + 1
END;
generate←word(right,0,csstart);
IF csend <> 0 THEN
insert←address(right,csend,laddr);
fstptr := next; lmin := lmin + 1
END
UNTIL fstptr = NIL
END
ELSE
BEGIN
IF NOT overrun THEN
BEGIN
overrun := true;
IF fprocp = NIL THEN
error←with←text(356,'MAIN ')
ELSE
error←with←text(356,fprocp↑.name)
END;
cix := 0
END
END;
IF sy = endsy THEN
insymbol
ELSE
error(163)
END (*CASESTATEMENT*) ;
PROCEDURE repeatstatement;
VAR
laddr: addrrange;
BEGIN (*REPEATSTATEMENT*)
laddr := ic;
LOOP
REPEAT
statement(fsys + [untilsy],statends + [untilsy])
UNTIL NOT (sy IN statbegsys)
EXIT IF sy <> semicolon;
insymbol
END;
IF sy = untilsy THEN
BEGIN
insymbol; expression(fsys,falsejmp); insert←address(right,cix,laddr)
END
ELSE
error(202)
END (*REPEATSTATEMENT*) ;
PROCEDURE whilestatement;
VAR
laddr: addrrange;
lcix: coderange;
BEGIN (*WHILESTATEMENT*)
laddr := ic;
expression(fsys + [dosy],falsejmp);
lcix := cix;
IF sy = dosy THEN
insymbol
ELSE
error(161);
statement(fsys,statends);
macro3r(254B(*JRST*),0,laddr);
insert←address(right,lcix,ic)
END (*WHILESTATEMENT*) ;
PROCEDURE forstatement;
VAR
lattr: attr;
lsp: stp;
lsy: symbol;
lcix: coderange;
laddr,ldplmt: addrrange;
linstr: instrange;
lregc,lindreg: acrange;
lindbit: ibrange;
lrelbyte: relbyte;
addtolc: addrrange;
BEGIN (*FORSTATEMENT*)
IF sy = ident THEN
BEGIN
searchid([vars],lcp);
WITH lcp↑, lattr DO
BEGIN
typtr := idtype; kind := varbl;
IF vkind = actual THEN
BEGIN
vlevel := vlev;
IF vlev > 1 THEN
vrelbyte := no
ELSE
vrelbyte := right;
dplmt := vaddr; indexr :=0; packfg := notpack;
indbit:=0
END
ELSE
BEGIN
error(364); typtr := NIL
END
END;
IF lattr.typtr <> NIL THEN
IF comptypes(realptr,lattr.typtr) OR (lattr.typtr↑.form > subrange) THEN
BEGIN
error(365); lattr.typtr := NIL
END;
insymbol
END
ELSE
BEGIN
errandskip(209,fsys + [becomes,tosy,downtosy,dosy]);
lattr.typtr := NIL
END;
IF sy = becomes THEN
BEGIN
insymbol; expression(fsys + [tosy,downtosy,dosy],onregc);
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.form <> scalar THEN
error(315)
ELSE
IF comptypes(lattr.typtr,gattr.typtr) THEN
load(gattr)
ELSE
error(556);
lregc := gattr.reg
END
ELSE
errandskip(159,fsys + [tosy,downtosy,dosy]);
IF sy IN [tosy,downtosy] THEN
BEGIN
lsy := sy; insymbol; expression(fsys + [dosy],onregc);
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.form <> scalar THEN
error(315)
ELSE
IF comptypes(lattr.typtr,gattr.typtr) THEN
BEGIN
addtolc := 0 ;
WITH gattr DO
IF ((kind = varbl) AND
(((vlevel > 1) AND (vlevel < level)) OR
(packfg <> notpack) OR
((indexr > 0) AND (indexr <= regcmax)))) OR
(kind = expr) THEN
BEGIN
load(gattr); macro4(202B(*MOVEM*),regc,basis,lc); addtolc := 1;
kind := varbl ; indbit := 0 ; indexr := basis ; vlevel := 1;
dplmt := lc ; packfg := notpack ; vrelbyte := no
END ;
fetch←basis(lattr);
WITH lattr DO
BEGIN
IF (indexr>0) AND (indexr<=regcmax) THEN
BEGIN
macro(no,551B(*HRRZI*),indexr,indbit,indexr,dplmt);
lindbit := 1; ldplmt := lc+addtolc; lindreg := basis ;
macro4(202B(*MOVEM*),indexr,basis,ldplmt);
addtolc := addtolc + 1
END
ELSE
BEGIN
lindbit := indbit; lindreg := indexr; ldplmt := dplmt
END;
lrelbyte:= vrelbyte
END;
macro(lrelbyte,202B(*MOVEM*),lregc,lindbit,lindreg,ldplmt);
IF lsy = tosy THEN
linstr := 313B(*CAMLE*)
ELSE
linstr := 315B(*CAMGE*);
laddr := ic;
generate←code(linstr,lregc,gattr)
END
ELSE
error(556)
END
ELSE
errandskip(251,fsys + [dosy]);
macro3(254B(*JRST*),0,0); lcix :=cix;
IF sy = dosy THEN
insymbol
ELSE
error(161);
lc := lc + addtolc;
IF lc > lcmax THEN
lcmax:=lc;
statement(fsys,statends);
lc := lc - addtolc;
IF lsy = tosy THEN
linstr := 350B(*AOS*)
ELSE
linstr := 370B(*SOS*);
macro(lrelbyte,linstr,lregc,lindbit,lindreg,ldplmt);
macro3r(254B(*JRST*),0,laddr); insert←address(right,lcix,ic)
END (*FORSTATEMENT*) ;
PROCEDURE loopstatement;
VAR
laddr: addrrange;
lcix: coderange;
BEGIN (*LOOPSTATEMENT*)
laddr := ic;
LOOP
REPEAT
statement(fsys + [exitsy],statends + [exitsy])
UNTIL NOT (sy IN statbegsys)
EXIT IF sy <> semicolon;
insymbol
END;
IF sy = exitsy THEN
BEGIN
insymbol;
IF sy = ifsy THEN
BEGIN
insymbol; expression(fsys + [semicolon,endsy],truejmp)
END
ELSE
errandskip(162,fsys + [semicolon,endsy]);
lcix := cix;
LOOP
REPEAT
statement(fsys,statends)
UNTIL NOT (sy IN statbegsys)
EXIT IF sy <> semicolon;
insymbol
END;
macro3r(254B(*JRST*),0,laddr); insert←address(right,lcix,ic)
END
ELSE
error(165);
IF sy = endsy THEN
insymbol
ELSE
error(163)
END (*LOOPSTATEMENT*) ;
PROCEDURE withstatement;
VAR
lcp: ctp; oldlc: addrrange; lcnt1: disprange; oldregc: acrange;
BEGIN (*WITHSTATEMENT*)
lcnt1 := 0; oldregc := regcmax; oldlc := lc;
LOOP
IF sy = ident THEN
BEGIN
searchid([vars,field],lcp); insymbol
END
ELSE
BEGIN
error(209); lcp := uvarptr
END;
selector(fsys + [comma,dosy],lcp);
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.form = records THEN
IF top < displimit THEN
BEGIN
top := top + 1; lcnt1 := lcnt1 + 1; withix := withix + 1;
WITH display[top], gattr DO
BEGIN
fname := typtr↑.fstfld;
occur := crec;
IF indbit = 1 THEN
get←parameter←address;
fetch←basis(gattr);
IF (indexr<>0) AND (indexr <> basis) THEN
BEGIN
macro3(550B(*HRRZ*),regcmax,indexr);
indexr := regcmax;
regcmax := regcmax-1;
IF regcmax<regc THEN
BEGIN
error(317);
regc := regcmax
END
END;
clev := vlevel; crelbyte := vrelbyte;
cindr := indexr; cindb:=indbit;
cdspl := dplmt;
clc := lc;
IF (cindr<>0) AND (cindr<>basis) THEN
BEGIN
lc := lc + 1;
IF lc>lcmax THEN
lcmax := lc
END
END
END
ELSE
error(404)
ELSE
error(308)
EXIT IF sy <> comma;
insymbol
END;
IF sy = dosy THEN
insymbol
ELSE
error(161);
statement(fsys,statends);
regcmax:=oldregc;
top := top - lcnt1; lc := oldlc; withix := withix - lcnt1
END (*WITHSTATEMENT*) ;
(* ]STATEMENT ]BODY ]BLOCK ]COMPILE *)
BEGIN (*STATEMENT*)
IF sy = intconst THEN
(*LABEL*)
BEGIN
searchid([labels],lcp);
IF lcp <> NIL THEN
WITH lcp↑ DO
BEGIN
IF label←address = 0 THEN
BEGIN
IF exit←jump THEN
macro3r(324B(*JUMPA*),reg0,ic+3);
label←address := ic;
IF exit←jump THEN
BEGIN
macro3r(200B(*MOVE*),basis,jump←table[jump←index]); code←reference↑[cix] := saveref;
macro3r(200B(*MOVE*),topp,jump←table[jump←index] + 1); code←reference↑[cix] := saveref;
jump←table[jump←index] := label←address
END
END
ELSE
error(211);
IF scope <> level THEN
error(352)
END;
insymbol;
IF sy = colon THEN
insymbol
ELSE
error(151)
END (* OF LABEL *);
IF NOT (sy IN fsys + [ident]) THEN
errandskip(166,fsys);
IF sy IN statbegsys + [ident] THEN
IF initglobals (* INSIDE AN INITPROCEDURE *) THEN
IF sy <> ident THEN
error(462)
ELSE
BEGIN
searchid([vars,field,func,proc],lcp); insymbol;
IF lcp↑.klass = proc THEN
error(462)
ELSE
assignment(lcp);
END
ELSE
(*...NOT INITGLOBALS*)
BEGIN
IF debug←switch THEN
put←linenumber;
regc := regin;
CASE sy OF
ident:
BEGIN
searchid([vars,field,func,proc],lcp); insymbol;
WITH lcp↑ DO
IF (klass = vars) AND (vlev = 0) AND (sy = arrow) AND
(idtype↑.form = files) AND (name = 'TTY ') THEN
BEGIN
id := 'TTYOUTPUT '; searchid([vars],lcp)
END;
IF lcp↑.klass = proc THEN
call(fsys,lcp)
ELSE
assignment(lcp)
END;
beginsy:
BEGIN
insymbol; compoundstatement
END;
gotosy:
BEGIN
insymbol; gotostatement
END;
ifsy:
BEGIN
insymbol; ifstatement
END;
casesy:
BEGIN
insymbol; casestatement
END;
whilesy:
BEGIN
insymbol; whilestatement
END;
repeatsy:
BEGIN
insymbol; repeatstatement
END;
loopsy:
BEGIN
insymbol; loopstatement
END;
forsy:
BEGIN
insymbol; forstatement
END;
withsy:
BEGIN
insymbol; withstatement
END
END (*CASE*) ;
(* RE-INITIALIZE REGISTER COUNTER TO AVOID OVERFLOW DURING SUBSEQUENT
EXPRESSION EVALUATIONS IN REPEATSTATEMENT OR LOOPSTATEMENT *)
regc := regin
END (*..NOT INITGLOBALS*);
skipiferr(statends,506,fsys)
END (*STATEMENT*) ;
BEGIN
(*BODY*)
regcmax:=within; withix := -1; firstkonst := NIL;
reg2←saved := false;
IF NOT entry←done THEN
BEGIN
entry←done:= true;
write←machine←code(write←entry);
write←machine←code(write←name);
write←machine←code(write←hiseg)
END;
cix := -1 ;
IF initglobals THEN
(* INSIDE AN INITPROCEDURE IN PASCAL*)
BEGIN
cglobptr := NIL ;
LOOP
IF sy <> endsy THEN
statement([semicolon,endsy],[semicolon,endsy])
EXIT IF sy <> semicolon ;
insymbol
END ;
IF sy = endsy THEN
insymbol
ELSE
error(163) ;
write←machine←code(write←globals)
END
ELSE
(* NOT INITGLOBALS *)
BEGIN
enterbody;
IF fprocp <> NIL THEN
fprocp↑.pfaddr:= pfstart
ELSE
lc:= 1;
lcmax:=lc;
LOOP
REPEAT
statement(fsys + [semicolon,endsy],[semicolon,endsy])
UNTIL NOT (sy IN statbegsys)
EXIT IF sy <> semicolon;
insymbol
END;
IF sy = endsy THEN
insymbol
ELSE
error(163);
leavebody;
insert←address(no,stacksize1,lcmax);
insert←address(no,stacksize2,lcmax);
write←machine←code(write←code);
IF debug THEN
write←machine←code(write←debug);
write←machine←code(write←internals);
IF level = 1 THEN
BEGIN
write←machine←code(write←fileblocks);
write←machine←code(write←symbols);
write←machine←code(write←library);
write←machine←code(write←start);
write←machine←code(write←end)
END
END
END (*BODY*) ;
BEGIN (*BLOCK*)
new(heapmark);
dp := true; testpacked := false; forward←procedures := NIL; current←jump := 0;
REPEAT
WHILE sy IN blockbegsys - [beginsy] DO
BEGIN
IF sy = labelsy THEN
BEGIN
insymbol; labeldeclaration
END;
IF sy = constsy THEN
BEGIN
insymbol; constantdeclaration
END;
IF sy = typesy THEN
BEGIN
insymbol; typedeclaration
END;
lcpar := lc;
IF sy = varsy THEN
BEGIN
insymbol; variabledeclaration
END;
IF (level > 1) AND (sy = initprocsy) THEN
errandskip(363,blockbegsys - [initprocsy]);
IF level = 1 THEN
BEGIN
WHILE sy = initprocsy DO
BEGIN
insymbol ;
IF sy <> semicolon THEN
errandskip(156,[beginsy])
ELSE
insymbol ;
IF sy = beginsy THEN
BEGIN
new(globmark); initglobals := true ;
insymbol ; body(fsys + [semicolon,endsy]) ;
IF sy = semicolon THEN
insymbol
ELSE
error(166) ;
initglobals := false; dispose(globmark)
END
ELSE
error(201)
END ;
lcmain := lc; testpacked := false
END;
WHILE sy IN [proceduresy,functionsy] DO
BEGIN
lsy := sy; insymbol; proceduredeclaration(lsy=proceduresy)
END;
WHILE forward←procedures <> NIL DO
WITH forward←procedures↑ DO
BEGIN
IF forwdecl THEN
error←with←text(465,name);
forward←procedures := testfwdptr
END;
skipiferr([beginsy],201,fsys)
END;
dp := false;
IF sy = beginsy THEN
insymbol
ELSE
error (201);
body(fsys + [casesy]);
skipiferr(leaveblocksys,166,fsys)
UNTIL sy IN leaveblocksys;
dispose(heapmark)
END (*BLOCK*) ;
BEGIN (* COMPILE *)
writeln(tty);
write(tty, header:6, ': ',object←file:6);
break(tty);
(* 6. KEEP FIRST PAGE FOR TTY MESSAGES.*)
firstpage := pagecnt;
error←in←heading := true;
getnextline; ch := ' '; insymbol; reset←possible := false;
new( code←array, pdp10code: code←size );
new( code←reference: code←size );
new( code←relocation: code←size );
(*******************************************************************************************
*
* <PROGRAM LIBRARY> ::= [<OPTION SEQUENCE>] [<PROGRAM>]*
* <PROGRAM> ::= <PROGRAM HEADING><BLOCK>.
* <PROGRAM HEADING> ::= PROGRAM <PROGRAMNAME>
* [,<ENTRY>]*
* [(<FILE IDENTIFIER>[,<FILE IDENTIFIER>]* )];
* <OPTION SEQUENCE> ::= ( *$ <OPTION>[,<OPTION>]* <ANY COMMENT> * )
* <OPTION> ::= <LETTER><SIGN>
* <LETTER> ::= [D, E, L, P, T, U]
* <SIGN> ::= [+, -]
*
* <PROGRAMNAME> ::= <IDENTIFIER>
* <FILE IDENTIFIER> ::= <IDENTIFIER>
* <ENTRY> ::= <IDENTIFIER>
*
************************************ COMPILER OPTIONS ************************************
*
* DEC-10 PASCAL FUNCTION DEFAULT
*
* [NO]LIST(+) - GENERATE LIST FILE OFF
* [NO]CODE L+/L- LIST OBJECT CODE OFF
* [NO]CHECK T+/T- PERFORM RUNTIME CHECKS ON
* [NO]DEBUG D+/D-, P+/P-($) GENERATE DEBUG INFORMATION
* INCLUDING POST-MORTEM DUMP OFF
* [NO]COMPILE(+) - COMPILE THE FILE ON
* [NO]EXTERN E+/E-(@) ALL LEVEL-1 PROCEDURES
* AND FUNCTIONS MAY BE DE-
* CLARED AS "EXTERN" BY OTHER
* PROGRAMS. THESE ENTRIES MUST
* BE DEFINED IN THE PROGRAM
* HEADING ADDITIONALLY OFF
* [NO]CARD U+/U-(@) ONLY 72 CHARS OF THE SOURCE
* LINE ARE ACCEPTED (CARD FORMAT) OFF
* FORTIO I+/I- ENABLE FORTRAN-I/O IN EXTERNAL
* FORTRAN PROGRAMS OFF
* CODESIZE:N SN MAXIMUM NUMBER OF
* CODE WORDS FOR A BODY CIXMAX
* RUNCORE:N RN SIZE OF LOW-SEGMENT LOW-BREAK
* FILE:N FN THIS OPTION IS
* NECESSARY IF FILES ARE
* DECLARED IN EXTERNAL PROGRAMS.
* N IS THE NUMBER OF FILES
* ALREADY DECLARED IN THE MAIN
* (AND/OR OTHER EXTERNAL)
* PROGRAM(S) PLUS 1 0
* [NO]CREF(+) - GENERATE CROSS REFERENCE LIST OFF
* [NO]LINK - CALL LINK-10 AFTER COMPILATION OFF
* [NO]EXECUTE - LOAD AND RUN COMPILED PROGRAM OFF
* REGISTER:N XN HIGHEST REGISTER USED
* TO PASS PARAMETERS STDPARREGCMAX
*
* SWITCHES MARKED WITH A (+) ARE ALSO PART OF THE DECSYSTEM-10 CONCISE COMMAND
* LANGUAGE. THE OTHERS MUST BE ENCLOSED IN "()" IF SPECIFIED
* IN A COMPILE-, LOAD-, EXECUTE- OR DEBUG-COMMAND-STRING,
* E.G.: COMPILE PASRL1=PASCAL.PAS(DEBUG/EXTERN)/LIST/COMPILE
*
* SWITCHES MARKED WITH ($) OR (@) MUST BE SPECIFIED FOR THE FIRST TIME BEFORE THE
* <PROGRAM HEADING>. THOSE WITH (@) CANNOT BE RE-DEFINED AGAIN INSIDE A <PROGRAM>,
* THOSE WITH ($) MIGHT BE RE-DEFINED INSIDE A <PROGRAM> OR
* <PROGRAM LIBRARY>. ALL OTHER SWITCHES CAN BE DEFINED AND
* RE-DEFINED ANYWHERE INSIDE A PROGRAM.
*
*******************************************************************************************)
IF external THEN
BEGIN
lc := low←start; lcmain := lc;
WHILE sfileptr <> NIL DO
WITH sfileptr↑, fileident↑ DO
BEGIN
vaddr := 0; sfileptr := nextftp
END;
sfileptr := fileptr
END;
IF sy = programsy THEN
BEGIN
insymbol;
IF sy = ident THEN
BEGIN
programname := id; escape := false;
WHILE (entries < entrymax) AND (sy = ident) AND NOT escape DO
BEGIN
entries := entries + 1;
entry[ entries ] := id;
insymbol;
IF sy = comma THEN
BEGIN
insymbol;
IF sy <> ident THEN
BEGIN
escape := true; error(209)
END
END
ELSE
IF NOT (sy IN [semicolon,lparent]) THEN
BEGIN
escape := true; error(156)
END
END;
IF sy = lparent THEN
BEGIN
REPEAT
insymbol;
IF sy = ident THEN
BEGIN
new(lparmptr);
IF parmptr = NIL THEN
parmptr := lparmptr;
WITH lparmptr↑ DO
BEGIN
fileid := id; fileidptr := NIL;
FOR i := 1 TO 2 DO
IF fileid = na[stdfile,i] THEN
BEGIN
fileidptr := stdfileptr[i];
IF i = 1 THEN
inputpar := true
ELSE
outputpar := true;
END;
nextptp := NIL;
IF backwparmptr <> NIL THEN
backwparmptr↑.nextptp := lparmptr;
backwparmptr := lparmptr; insymbol;
IF (sy IN [mulop,addop]) AND (op IN [mul,plus]) THEN
BEGIN
IF op = plus THEN
error(169);
inputfile := true; insymbol
END
END
END
ELSE
(*SY <> IDENT*)
error(209)
UNTIL sy <> comma;
IF sy <> rparent THEN
errandskip(152,blockbegsys)
ELSE
BEGIN
insymbol;
skipiferr([semicolon],156,blockbegsys)
END
END
ELSE
(*SY <> LPARENT*)
skipiferr([semicolon],156,blockbegsys)
END
ELSE
(*SY <> IDENT*)
errandskip(209,blockbegsys)
END
ELSE
(*SY <> PROGRAMSY*)
errandskip(318,blockbegsys);
IF sy = semicolon THEN
insymbol;
IF NOT error←flag THEN
BEGIN
write(tty, ' [ ', programname);
IF (entries > 1) AND external THEN
BEGIN
write(tty,': '); i := 2;
LOOP
write(tty,entry[i])
EXIT IF i >= entries;
i := i + 1;
write(tty,', ')
END
END;
(* 6. GIVE PAGE NUMBERS ON TTY.*)
write (tty, ' ] PAGE');
FOR i := firstpage TO pagecnt DO
write (tty, i:3,'..');
break(tty);
END;
block(NIL,blockbegsys + statbegsys-[casesy],[period,colon]);
error←exit := true; endofline;
111:
IF lptfile THEN
BEGIN
writeln(list);
writeln(list,errorcount:4,' ERROR(S) DETECTED');
writeln(list)
END;
writeln(tty);
writeln(tty,errorcount:4,' ERROR(S) DETECTED');
IF error←flag THEN
(* 13.*)
no←code←gen := true
ELSE
BEGIN
core[1] := highest←code-high←start; core[2] := core[1] MOD 1024;
core[1] := core[1] DIV 1024;
IF lptfile THEN
writeln(list,'HIGHSEG: ',core[1]:3,'K + ',core[2]:4,' WORD(S)');
writeln(tty,'HIGHSEG: ',core[1]:3,'K + ',core[2]:4,' WORD(S)');
core[1] := lcmain DIV 1024; core[2] := lcmain MOD 1024;
IF lptfile THEN
BEGIN
writeln(list,'LOWSEG : ',core[1]:3,'K + ',core[2]:4,' WORD(S)'); writeln(list)
END;
writeln(tty,'LOWSEG : ',core[1]:3,'K + ',core[2]:4,' WORD(S)');
END;
dispose( code←array, pdp10code: code←size )
END (* COMPILE *);
PROCEDURE reporttime; (* 22. USE THE LIBRARY PROCEDURES*)
VAR
rtime, elapstime: alfa;
BEGIN (* REPORTTIME *)
runtime(rtime);
elapsedtime (elapstime);
IF lptfile THEN
BEGIN
writeln(list);
write(list,'RUNTIME: ',rtime);
writeln(list,' ':5,'ELAPSED: ',elapstime);
END;
writeln(tty);
write(tty,'RUNTIME: ',rtime); (* 13. NO BEL UNLESS STOPPING.*)
writeln(tty,' ':5,'ELAPSED: ',elapstime);
break(tty);
END (* REPORTTIME *);
(* MAIN BODY. *)
BEGIN (*PASCAL*)
settime; (* 22.*)
date(day); time(timeofday);
init←compile;
(*ENTER STANDARD NAMES AND STANDARD TYPES:*)
(******************************************)
level := 0; top := 0;
WITH display[0] DO
BEGIN
fname := NIL; occur := blck
END;
enterstdtypes; enterstdnames; enterundecl;
top := 1; level := 1;
WITH display[1] DO
BEGIN
fname := NIL; occur := blck
END;
get←directives;
IF NOT option('NOCOMPILE ') THEN
BEGIN
IF lptfile THEN
BEGIN
writeln(list,'PASCAL COMPILATION LIST PRODUCED BY ',header,' ON ',day,' AT ',timeofday); writeln(list)
END;
LOOP
compile
EXIT IF NOT external OR eof(source);
init←compile
END;
END (* IF NOT OPTION('NOCOMPILE ') *);
0:
reporttime;
IF NOT no←code←gen THEN
(* 13. ERRORS OF ALL THE FILE, NOT ONLY THE LAST MODULE*)
BEGIN
IF cross←reference THEN
BEGIN
(* 14. NO LPTFILE IF CROSS←REFERENCE*)
rewrite(tempcore,pcross←tmpfile);
write(tempcore,source←file:6, '.' ,
source←file[7],source←file[8],source←file[9], ',' ,
source←file:6,'.NEW,',source←file:6,'.CRL');
FOR i := 1 TO maxpcrossoption DO
IF option (pcross←option←name [i]) THEN
BEGIN
write (tempcore, '/',pcross←option←name [i]);
getoption (pcross←option←name [i], j);
IF j <> 0 THEN
write (tempcore, ':', j:3);
END;
writeln (tempcore);
(* 1., 4. PASS THE LINKER NAME TO PCROSS.*)
IF load←and←go THEN
BEGIN
FOR i := 1 TO 6 DO
IF link←device [i] = ' ' THEN
i := 7
ELSE
write (tempcore, link←device [i]);
write(tempcore,':');
FOR i := 1 TO 6 DO
IF linker←file [i] = ' ' THEN
i := 7
ELSE
write (tempcore, linker←file[i]);
writeln (tempcore,'!');
END;
call(pcross←file,pcross←device,pcross←ppn,pcross←core) (* 4.*)
END;
IF load←and←go THEN
BEGIN
writeln(tty); break(tty);
call(linker←file,link←device) (* 1.*)
END
END
ELSE
BEGIN
rewrite(object);
rewrite(tempcore,link←tmpfile);
writeln(tty);
writeln(tty,'EXECUTION SUPPRESSED');
END;
write (tty,bel);
END (*PASCAL*).